From bdaef69556f68595e5ec0db1710bf8ad208abe20 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Fri, 11 Aug 2023 11:21:42 -0400
Subject: 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        |  5 +++-
 guix/gnu-maintenance.scm | 65 +++++++++++++++++++++++++++++-------------------
 2 files changed, 44 insertions(+), 26 deletions(-)

(limited to 'guix')

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 @@
 ;;; 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 228a84bd4b..eb30b7874f 100644
--- a/guix/gnu-maintenance.scm
+++ b/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?
-  ;; 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))
-                                 ;; HOST may contain prefixes,
-                                 ;; e.g. "profanity-im.github.io", hence the
-                                 ;; suffix-based test below.
-                                 (not (any (cut string-suffix? <> 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))
+                ;; HOST may contain prefixes, e.g. "profanity-im.github.io",
+                ;; hence the suffix-based test below.
+                (not (any (cut string-suffix? <> 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
@@ -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)
-- 
cgit v1.2.3