diff options
| -rw-r--r-- | guix/download.scm | 5 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 65 |
2 files changed, 44 insertions, 26 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 @@ ;;; 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) |