gnu-maintenance: Allow mirror URLs to fallback to the generic HTML updater.

* 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.

guix/download.scm

@@ -51,7 +51,10 @@
 ;;; 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.

guix/gnu-maintenance.scm

@@ -928,31 +928,43 @@ Optionally include a VERSION string to fetch a specific version."
                          #:directory directory
                          #:file->signature file->signature)))
 
-(define html-updatable-package?
+;;; These sites are disallowed for the generic HTML updater as there are
-  ;; Return true if the given package may be handled by the generic HTML
+;;; better means to query them.
-  ;; updater.
+(define %disallowed-hosting-sites
-  (let ((hosting-sites '("github.com" "github.io" "gitlab.com"
+  '("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")))
+    "bioconductor.org"))
-    (define http-url?
+
-      (url-predicate (lambda (url)
+(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)))
-                            (and (memq scheme '(http https))
+       (or (and (memq scheme '(http https))
-                                 ;; HOST may contain prefixes,
+                ;; HOST may contain prefixes, e.g. "profanity-im.github.io",
-                                 ;; e.g. "profanity-im.github.io", hence the
+                ;; hence the suffix-based test below.
-                                 ;; suffix-based test below.
                 (not (any (cut string-suffix? <> host)
-                                           hosting-sites)))))))))
+                          %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))))))))))
 
-    (lambda (package)
+(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)
-          (http-url? package)))))
+      ((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
@@ -960,6 +972,9 @@ the directory containing its source tarball.  Optionally include a VERSION
 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)