[bug#65230] [PATCH v2 12/13] gnu-maintenance: Allow mirror URLs to fallback to the generic HTML updater.

[Maxim Cournoyer <maxim.cournoyer@gmail.com>]

* guix/gnu-maintenance.scm (http-url?): Extract from html-updatable-package?,
modify to return the HTTP URL, and support the mirror:// scheme.
(%disallowed-hosting-sites): New variable, extracted from
html-updatable-package.
(html-updatable-package?): Rewrite a mirror:// URL to an HTTP or HTTPS one.
* guix/download.scm (%mirrors): Update comment.

---

Changes in v2:
- Update %mirrors comment to mention speed-related exceptions

 guix/download.scm        |  5 +++-
 guix/gnu-maintenance.scm | 58 +++++++++++++++++++++++++---------------
 2 files changed, 41 insertions(+), 22 deletions(-)

diff --git a/guix/download.scm b/guix/download.scm
index ce6ebd0df8..31a41e8183 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -51,7 +51,10 @@ (define-module (guix download)
 ;;; Code:
 
 (define %mirrors
-  ;; Mirror lists used when `mirror://' URLs are passed.
+  ;; Mirror lists used when `mirror://' URLs are passed.  The first mirror
+  ;; entry of each set should ideally be the most authoritative one, as that's
+  ;; what the generic HTML updater will pick to look for updates, with
+  ;; possible exceptions when the authoritative mirror is too slow.
   (let* ((gnu-mirrors
           '(;; This one redirects to a (supposedly) nearby and (supposedly)
             ;; up-to-date mirror.
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 3cd84ee3d7..2574e0f827 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -928,27 +928,40 @@ (define* (import-kernel.org-release package #:key (version #f))
                          #:directory directory
                          #:file->signature file->signature)))
 
-(define html-updatable-package?
-  ;; Return true if the given package may be handled by the generic HTML
-  ;; updater.
-  (let ((hosting-sites '("github.com" "github.io" "gitlab.com"
-                         "notabug.org" "sr.ht" "gitlab.inria.fr"
-                         "ftp.gnu.org" "download.savannah.gnu.org"
-                         "pypi.org" "crates.io" "rubygems.org"
-                         "bioconductor.org")))
-    (define http-url?
-      (url-predicate (lambda (url)
-                       (match (string->uri url)
-                         (#f #f)
-                         (uri
-                          (let ((scheme (uri-scheme uri))
-                                (host   (uri-host uri)))
-                            (and (memq scheme '(http https))
-                                 (not (member host hosting-sites)))))))))
-
-    (lambda (package)
-      (or (assoc-ref (package-properties package) 'release-monitoring-url)
-          (http-url? package)))))
+;;; These sites are disallowed for the generic HTML updater as there are
+;;; better means to query them.
+(define %disallowed-hosting-sites
+  '("github.com" "github.io" "gitlab.com"
+    "notabug.org" "sr.ht" "gitlab.inria.fr"
+    "ftp.gnu.org" "download.savannah.gnu.org"
+    "pypi.org" "crates.io" "rubygems.org"
+    "bioconductor.org"))
+
+(define (http-url? url)
+  "Return URL if URL has HTTP or HTTPS as its protocol.  If URL uses the
+special mirror:// protocol, substitute it with the first HTTP or HTTPS URL
+prefix from its set."
+  (match (string->uri url)
+    (#f #f)
+    (uri
+     (let ((scheme (uri-scheme uri))
+           (host   (uri-host uri)))
+       (or (and (memq scheme '(http https))
+                (not (member host %disallowed-hosting-sites))
+                url)
+           (and (eq? scheme 'mirror)
+                (and=> (find http-url?
+                             (assoc-ref %mirrors
+                                        (string->symbol host)))
+                       (lambda (url)
+                         (string-append (strip-trailing-slash url)
+                                        (uri-path uri))))))))))
+
+(define (html-updatable-package? package)
+  "Return true if the given package may be handled by the generic HTML
+updater."
+  (or (assoc-ref (package-properties package) 'release-monitoring-url)
+      ((url-predicate http-url?) package)))
 
 (define* (import-html-updatable-release package #:key (version #f))
   "Return the latest release of PACKAGE.  Do that by crawling the HTML page of
@@ -956,6 +969,9 @@ (define* (import-html-updatable-release package #:key (version #f))
 string to fetch a specific version."
   (let* ((uri       (string->uri
                      (match (origin-uri (package-source package))
+                       ((? (cut string-prefix? "mirror://" <>) url)
+                        ;; Retrieve the authoritative HTTP URL from a mirror.
+                        (http-url? url))
                        ((? string? url) url)
                        ((url _ ...) url))))
          (custom    (assoc-ref (package-properties package)
-- 
2.41.0