diff options
Diffstat (limited to 'guix/gnu-maintenance.scm')
| -rw-r--r-- | guix/gnu-maintenance.scm | 72 |
1 files changed, 38 insertions, 34 deletions
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 1ffa408666..f983debcd2 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -33,6 +33,8 @@ #:use-module (rnrs io ports) #:use-module (system foreign) #:use-module ((guix http-client) #:hide (open-socket-for-uri)) + ;; not required in many cases, so autoloaded to reduce start-up costs. + #:autoload (guix download) (%mirrors) #:use-module (guix ftp-client) #:use-module (guix utils) #:use-module (guix memoization) @@ -58,6 +60,8 @@ find-package gnu-package? + uri-mirror-rewrite + release-file? releases latest-release @@ -359,10 +363,12 @@ return the corresponding signature URL, or #f it signatures are unavailable." (upstream-source (package project) (version (tarball->version file)) - (urls (list url)) + ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp:// + ;; URLs during "guix refresh -u". + (urls (list (uri-mirror-rewrite url))) (signature-urls (match (file->signature url) (#f #f) - (sig (list sig))))))) + (sig (list (uri-mirror-rewrite sig)))))))) (let loop ((directory directory) (result #f)) @@ -532,9 +538,12 @@ are unavailable." (upstream-source (package package) (version version) - (urls (list url)) + ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp:// + ;; URLs during "guix refresh -u". + (urls (list (uri-mirror-rewrite url))) (signature-urls - (list ((or file->signature file->signature/guess) url)))))))) + (and=> ((or file->signature file->signature/guess) url) + (lambda (url) (list (uri-mirror-rewrite url)))))))))) (define candidates (filter-map url->release links)) @@ -651,21 +660,22 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." (define gnu-hosted? (url-prefix-predicate "mirror://gnu/")) -(define (url-prefix-rewrite old new) - "Return a one-argument procedure that rewrites URL prefix OLD to NEW." - (lambda (url) - (if (and url (string-prefix? old url)) - (string-append new (string-drop url (string-length old))) - url))) - -(define (adjusted-upstream-source source rewrite-url) - "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them." - (upstream-source - (inherit source) - (urls (map rewrite-url (upstream-source-urls source))) - (signature-urls (and=> (upstream-source-signature-urls source) - (lambda (urls) - (map rewrite-url urls)))))) +(define (uri-mirror-rewrite uri) + "Rewrite URI to a mirror:// URI if possible, or return URI unmodified." + (if (string-prefix? "mirror://" uri) + uri ;nothing to do, it's already a mirror URI + (let loop ((mirrors %mirrors)) + (match mirrors + (() + uri) + (((mirror-id mirror-urls ...) rest ...) + (match (find (cut string-prefix? <> uri) mirror-urls) + (#f + (loop rest)) + (prefix + (format #f "mirror://~a/~a" + mirror-id + (string-drop uri (string-length prefix)))))))))) (define %savannah-base ;; One of the Savannah mirrors listed at @@ -680,15 +690,12 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." ((? string? uri) uri) ((uri mirrors ...) uri)))) (package (package-upstream-name package)) - (directory (dirname (uri-path uri))) - (rewrite (url-prefix-rewrite %savannah-base - "mirror://savannah"))) + (directory (dirname (uri-path uri)))) ;; Note: We use the default 'file->signature', which adds ".sig", ".asc", ;; or whichever detached signature naming scheme PACKAGE uses. - (and=> (latest-html-release package - #:base-url %savannah-base - #:directory directory) - (cut adjusted-upstream-source <> rewrite)))) + (latest-html-release package + #:base-url %savannah-base + #:directory directory))) (define (latest-sourceforge-release package) "Return the latest release of PACKAGE." @@ -768,14 +775,11 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." ((? string? uri) uri) ((uri mirrors ...) uri)))) (package (package-upstream-name package)) - (directory (dirname (uri-path uri))) - (rewrite (url-prefix-rewrite %kernel.org-base - "mirror://kernel.org"))) - (and=> (latest-html-release package - #:base-url %kernel.org-base - #:directory directory - #:file->signature file->signature) - (cut adjusted-upstream-source <> rewrite)))) + (directory (dirname (uri-path uri)))) + (latest-html-release package + #:base-url %kernel.org-base + #:directory directory + #:file->signature file->signature))) (define html-updatable-package? ;; Return true if the given package may be handled by the generic HTML |