me/guix
Archived
1
0
Fork 0
Code Activity

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

Browse source 
* 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.
This commit is contained in:
Maxim Cournoyer 2023-08-11 11:21:42 -04:00
parent 6953fb9241
commit bdaef69556
No known key found for this signature in database
GPG key ID: 1260E46482E63562
2 changed files with 43 additions and 25 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
guix/download.scm
View file

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

43
guix/gnu-maintenance.scm
View file

@ -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"
;;; 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-predicate (lambda (url)
"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)))
(and (memq scheme '(http https))
;; HOST may contain prefixes,
;; e.g. "profanity-im.github.io", hence the
;; suffix-based test below.
(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)
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)