[bug#57515] [PATCH 1/8] guix: Extract logic of the check-mirror-url.

[bug#57515] [PATCH 1/8] guix: Extract logic of the check-mirror-url.

[Maxime Devos]

It will be useful for fixing #57477 ‘"guix refresh -u" sometimes 'unmirrors'
source URLs’.

* guix/lint.scm (check-mirror-url): Extract mirror://-constructing code to ...
* guix/gnu-maintenance.scm (uri-mirror-rewrite): ... here, tweaking the API
and implementation in anticipation of future users.
---
 guix/gnu-maintenance.scm | 23 +++++++++++++++++++++++
 guix/lint.scm            | 23 +++++++----------------
 2 files changed, 30 insertions(+), 16 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index e7edbf6656..51e8fcd815 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,6 +33,8 @@ (define-module (guix gnu-maintenance)
   #:use-module (rnrs io ports)
   #:use-module (system foreign)
   #:use-module ((guix http-client) #:hide (open-socket-for-uri))
+  ;; not required in many cases, so autoloaded to reduce start-up costs.
+  #:autoload   (guix download) (%mirrors)
   #:use-module (guix ftp-client)
   #:use-module (guix utils)
   #:use-module (guix memoization)
@@ -57,6 +60,8 @@ (define-module (guix gnu-maintenance)
             find-package
             gnu-package?
 
+            uri-mirror-rewrite
+
             release-file?
             releases
             latest-release
@@ -651,6 +656,24 @@ (define (url-prefix-rewrite old new)
         (string-append new (string-drop url (string-length old)))
         url)))
 
+(define (uri-mirror-rewrite uri)
+  "Rewrite URI to a mirror:// URI if possible. When not, return URI unmodified."
+  (if (string-prefix? "mirror://" uri)
+      ;; Nothing to do, it's already a mirror URI!
+      uri
+      (let loop ((mirrors %mirrors))
+        (match mirrors
+          (()
+           uri)
+          (((mirror-id mirror-urls ...) rest ...)
+           (match (find (cut string-prefix? <> uri) mirror-urls)
+             (#f
+              (loop rest))
+             (prefix
+              (format #f "mirror://~a/~a"
+                      mirror-id
+                      (string-drop uri (string-length prefix))))))))))
+
 (define (adjusted-upstream-source source rewrite-url)
   "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them."
   (upstream-source
diff --git a/guix/lint.scm b/guix/lint.scm
index edba1c2663..ff7863ab86 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -12,7 +12,7 @@
 ;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
-;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -1223,21 +1223,12 @@ (define (check-source-uri uri)
 (define (check-mirror-url package)
   "Check whether PACKAGE uses source URLs that should be 'mirror://'."
   (define (check-mirror-uri uri)                  ;XXX: could be optimized
-    (let loop ((mirrors %mirrors))
-      (match mirrors
-        (()
-         #f)
-        (((mirror-id mirror-urls ...) rest ...)
-         (match (find (cut string-prefix? <> uri) mirror-urls)
-           (#f
-            (loop rest))
-           (prefix
-            (make-warning package
-                          (G_ "URL should be \
-'mirror://~a/~a'")
-                          (list mirror-id
-                                (string-drop uri (string-length prefix)))
-                          #:field 'source)))))))
+    (define maybe-rewritten-uri (uri-mirror-rewrite uri))
+    (and (not (eq? uri maybe-rewritten-uri))
+         (make-warning package
+                       (G_ "URL should be '~a'")
+                       (list maybe-rewritten-uri)
+                       #:field 'source)))
 
   (let ((origin (package-source package)))
     (if (and (origin? origin)
-- 
2.37.2

[bug#57515] [PATCH 2/8] gnu-maintenance: Produce mirror:// URIs in latest-ftp-release.

[Maxime Devos]

Partially fixes: https://issues.guix.gnu.org/57477.
As a test, try updating gnupg. Before the patch, a ftp:// URL was produced,
now the mirror:// is preserved.

* guix/gnu-maintenance.scm (latest-ftp-release)[file->source]{urls,signature-urls}:
Call uri-mirror-rewrite on the URLs.
---
 guix/gnu-maintenance.scm | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 51e8fcd815..84fd087319 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -363,10 +363,12 @@ (define (file->source directory file)
       (upstream-source
        (package project)
        (version (tarball->version file))
-       (urls (list url))
+       ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
+       ;; URLs during "guix refresh -u".
+       (urls (list (uri-mirror-rewrite url)))
        (signature-urls (match (file->signature url)
                          (#f #f)
-                         (sig (list sig)))))))
+                         (sig (list (uri-mirror-rewrite sig))))))))
 
   (let loop ((directory directory)
              (result    #f))
-- 
2.37.2

[bug#57515] [PATCH 3/8] gnu-maintenance: Produce mirror:// URIs in latest-html-release.

[Maxime Devos]

Partially fixes: https://issues.guix.gnu.org/57477.

TODO: test case, it's http!

I'm not aware of a package using both latest-html-release and mirrors, so it
has not been completely tested.  However, updating "yt-dlp" appears to work
(except for git-fetch not being supported yet).  The expression for the
signature-urls field had to be tweaked to not call uri-mirror-rewrite on #false.

* guix/gnu-maintenance.scm (latest-html-release)[url->research]{urls,signature-urls}:
Call uri-mirror-rewrite on the URLs.
---
 guix/gnu-maintenance.scm | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 84fd087319..2f09539d5d 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -532,9 +532,12 @@ (define (url->release url)
                (upstream-source
                 (package package)
                 (version version)
-                (urls (list url))
+                ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
+                ;; URLs during "guix refresh -u".
+                (urls (list (uri-mirror-rewrite url)))
                 (signature-urls
-                 (list ((or file->signature file->signature/guess) url))))))))
+                 (and=> ((or file->signature file->signature/guess) url)
+                        (lambda (url) (list (uri-mirror-rewrite url))))))))))
 
     (define candidates
       (filter-map url->release links))
-- 
2.37.2

[bug#57515] [PATCH 4/8] download: Switch savannah mirrors to HTTPS URLs.

[Maxime Devos]

The URI scheme used for nongnu.freemirror.org needs to be consistent
between (guix download) and (guix gnu-maintenance) to make the simplified
savannah-updater (of a later commit) work.  While we're at it, switch the
other mirrors to https as well.

http://download.savannah.gnu.org/releases-noredirect/ is left unmodified
because it 404s

* download.scm (%mirrors)[savannah]: Switch from http to https where possible.
---
 guix/download.scm | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/guix/download.scm b/guix/download.scm
index d459ba8cf1..ac88b215de 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -96,15 +96,15 @@ (define %mirrors
       (hackage
        "http://hackage.haskell.org/")
       (savannah           ; http://download0.savannah.gnu.org/mirmon/savannah/
-       "http://download.savannah.gnu.org/releases/"
-       "http://nongnu.freemirror.org/nongnu/"
-       "http://ftp.cc.uoc.gr/mirrors/nongnu.org/"
-       "http://ftp.twaren.net/Unix/NonGNU/"
-       "http://mirror.csclub.uwaterloo.ca/nongnu/"
-       "http://nongnu.askapache.com/"
-       "http://savannah.c3sl.ufpr.br/"
+       "https://download.savannah.gnu.org/releases/"
+       "https://nongnu.freemirror.org/nongnu/"
+       "https://ftp.cc.uoc.gr/mirrors/nongnu.org/"
+       "http://ftp.twaren.net/Unix/NonGNU/" ; https appears unsupported
+       "https://mirror.csclub.uwaterloo.ca/nongnu/"
+       "https://nongnu.askapache.com/"
+       "https://savannah.c3sl.ufpr.br/"
        "http://download.savannah.gnu.org/releases-noredirect/"
-       "http://download-mirror.savannah.gnu.org/releases/"
+       "https://download-mirror.savannah.gnu.org/releases/"
        "ftp://ftp.twaren.net/Unix/NonGNU/"
        "ftp://mirror.csclub.uwaterloo.ca/nongnu/"
        "ftp://mirror.publicns.net/pub/nongnu/"
-- 
2.37.2

[bug#57515] [PATCH 5/8] gnu-maintenance: Simplify latest-savannah-release.

[Maxime Devos]

As latest-html-release now produces mirror:// URIs where possible,
the additional post-processing is not necessary anymore.

As a test, try updating 'gash', the mirror:// URI remains.

* gnu-maintenance.scm (latest-savannah-release): Do not call
adjusted-upstream-source on the result.
---
 guix/gnu-maintenance.scm | 11 ++++-------
 1 file changed, 4 insertions(+), 7 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 2f09539d5d..853ad91ea0 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -701,15 +701,12 @@ (define (latest-savannah-release package)
                        ((? string? uri) uri)
                        ((uri mirrors ...) uri))))
          (package   (package-upstream-name package))
-         (directory (dirname (uri-path uri)))
-         (rewrite   (url-prefix-rewrite %savannah-base
-                                        "mirror://savannah")))
+         (directory (dirname (uri-path uri))))
     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
     ;; or whichever detached signature naming scheme PACKAGE uses.
-    (and=> (latest-html-release package
-                                #:base-url %savannah-base
-                                #:directory directory)
-           (cut adjusted-upstream-source <> rewrite))))
+    (latest-html-release package
+                         #:base-url %savannah-base
+                         #:directory directory)))
 
 (define (latest-sourceforge-release package)
   "Return the latest release of PACKAGE."
-- 
2.37.2

[bug#57515] [PATCH 6/8] download: Add a kernel.org mirror.

[Maxime Devos]

Add the mirror from (guix gnu-maintenance) to make the simplified
linux.org updater (of a later commit) work.

* download.scm (%mirrors)[kernel.org]: Add mirrors.edge.kernel.org mirror.
---
 guix/download.scm | 1 +
 1 file changed, 1 insertion(+)

diff --git a/guix/download.scm b/guix/download.scm
index ac88b215de..29a8f99034 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -138,6 +138,7 @@ (define %mirrors
        "http://kernel.osuosl.org/pub/"
        "http://ftp.be.debian.org/pub/"
        "http://mirror.linux.org.au/"
+       "https://mirrors.edge.kernel.org/pub/"
        "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/")
       (apache             ; from http://www.apache.org/mirrors/dist.html
        "http://www.eu.apache.org/dist/"
-- 
2.37.2

[bug#57515] [PATCH 7/8] gnu-maintenance: Simplify latest-kernel.org-release.

[Maxime Devos]

As latest-html-release now produces mirror:// URIs where possible,
the additional post-processing is not necessary anymore.

As a test, revert the dtc package back to 1.6.0 and try updating 'gash',
the mirror:// URI remains.

* gnu-maintenance.scm (latest-kernel.org-release): Do not call
adjusted-upstream-source on the result.
---
 guix/gnu-maintenance.scm | 13 +++++--------
 1 file changed, 5 insertions(+), 8 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 853ad91ea0..7cb830b849 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -786,14 +786,11 @@ (define (file->signature file)
                        ((? string? uri) uri)
                        ((uri mirrors ...) uri))))
          (package   (package-upstream-name package))
-         (directory (dirname (uri-path uri)))
-         (rewrite   (url-prefix-rewrite %kernel.org-base
-                                        "mirror://kernel.org")))
-    (and=> (latest-html-release package
-                                #:base-url %kernel.org-base
-                                #:directory directory
-                                #:file->signature file->signature)
-           (cut adjusted-upstream-source <> rewrite))))
+         (directory (dirname (uri-path uri))))
+    (latest-html-release package
+                         #:base-url %kernel.org-base
+                         #:directory directory
+                         #:file->signature file->signature)))
 
 (define html-updatable-package?
   ;; Return true if the given package may be handled by the generic HTML
-- 
2.37.2

[bug#57515] [PATCH 8/8] gnu-maintenance: Remove unused procedures.

[Maxime Devos]

* guix/gnu-maintenance.scm (url-prefix-rewrite, adjusted-upstream-source):
Remove.
---
 guix/gnu-maintenance.scm | 16 ----------------
 1 file changed, 16 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 7cb830b849..2e8b08caa3 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -654,13 +654,6 @@ (define (pure-gnu-package? package)
 (define gnu-hosted?
   (url-prefix-predicate "mirror://gnu/"))
 
-(define (url-prefix-rewrite old new)
-  "Return a one-argument procedure that rewrites URL prefix OLD to NEW."
-  (lambda (url)
-    (if (and url (string-prefix? old url))
-        (string-append new (string-drop url (string-length old)))
-        url)))
-
 (define (uri-mirror-rewrite uri)
   "Rewrite URI to a mirror:// URI if possible. When not, return URI unmodified."
   (if (string-prefix? "mirror://" uri)
@@ -679,15 +672,6 @@ (define (uri-mirror-rewrite uri)
                       mirror-id
                       (string-drop uri (string-length prefix))))))))))
 
-(define (adjusted-upstream-source source rewrite-url)
-  "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them."
-  (upstream-source
-   (inherit source)
-   (urls (map rewrite-url (upstream-source-urls source)))
-   (signature-urls (and=> (upstream-source-signature-urls source)
-                          (lambda (urls)
-                            (map rewrite-url urls))))))
-
 (define %savannah-base
   ;; One of the Savannah mirrors listed at
   ;; <http://download0.savannah.gnu.org/mirmon/savannah/> that serves valid
-- 
2.37.2