05/06: Revert "gnu-maintenance: Allow mirror URLs to fallback to the generic HTML updater."

[guix-commits]

janneke pushed a commit to branch hurd-team
in repository guix.

commit c0c6832f0e4ed8790c09ff11f5bc675dcead651a
Author: Janneke Nieuwenhuizen <janneke@gnu.org>
AuthorDate: Sat Sep 23 10:46:53 2023 +0200

    Revert "gnu-maintenance: Allow mirror URLs to fallback to the generic HTML 
updater."
    
    This reverts commit bdaef69556f68595e5ec0db1710bf8ad208abe20.
---
 guix/download.scm        |  5 +---
 guix/gnu-maintenance.scm | 65 +++++++++++++++++++-----------------------------
 2 files changed, 26 insertions(+), 44 deletions(-)

diff --git a/guix/download.scm b/guix/download.scm
index 31a41e8183..ce6ebd0df8 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -51,10 +51,7 @@
 ;;; Code:
 
 (define %mirrors
-  ;; 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.
+  ;; Mirror lists used when `mirror://' URLs are passed.
   (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 0383e8d353..37c18bb192 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -841,43 +841,31 @@ Optionally include a VERSION string to fetch a specific 
version."
                          #:directory directory
                          #:file->signature file->signature)))
 
-;;; 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 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)))))
 
 (define* (import-html-updatable-release package #:key (version #f))
   "Return the latest release of PACKAGE.  Do that by crawling the HTML page of
@@ -885,9 +873,6 @@ 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)