diff options
author | Maxime Devos <maximedevos@telenet.be> | 2022-09-01 11:01:48 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2022-09-26 23:29:36 +0200 |
commit | fc5c4ce4ec2ecf6b7d9e227617777d8dd10b903a (patch) | |
tree | fbcbbeb278b1394c3fa5b64e5a10f28fd3738ca3 /guix | |
parent | b6274a20e8e99fa6287264289da42ed364fc976c (diff) |
lint: Extract logic of 'check-mirror-url'.
It will be useful for fixing <https://issues.guix.gnu.org/57477>.
* guix/lint.scm (check-mirror-url): Extract mirror://-constructing code to ...
* guix/gnu-maintenance.scm (uri-mirror-rewrite): ... here, tweaking the API
and implementation in anticipation of future users.
Co-authored-by: Ludovic Courtès <ludo@gnu.org>
Diffstat (limited to 'guix')
-rw-r--r-- | guix/gnu-maintenance.scm | 21 | ||||
-rw-r--r-- | guix/lint.scm | 26 |
2 files changed, 30 insertions, 17 deletions
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 1ffa408666..20e3bc1cba 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 @@ -658,6 +662,23 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." (string-append new (string-drop url (string-length old))) url))) +(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 (adjusted-upstream-source source rewrite-url) "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them." (upstream-source diff --git a/guix/lint.scm b/guix/lint.scm index edba1c2663..7ee3a3122f 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -12,7 +12,7 @@ ;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> -;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> ;;; ;;; This file is part of GNU Guix. @@ -1222,22 +1222,14 @@ descriptions maintained upstream." (define (check-mirror-url package) "Check whether PACKAGE uses source URLs that should be 'mirror://'." - (define (check-mirror-uri uri) ;XXX: could be optimized - (let loop ((mirrors %mirrors)) - (match mirrors - (() - #f) - (((mirror-id mirror-urls ...) rest ...) - (match (find (cut string-prefix? <> uri) mirror-urls) - (#f - (loop rest)) - (prefix - (make-warning package - (G_ "URL should be \ -'mirror://~a/~a'") - (list mirror-id - (string-drop uri (string-length prefix))) - #:field 'source))))))) + (define (check-mirror-uri uri) + (define rewritten-uri + (uri-mirror-rewrite uri)) + + (and (not (string=? uri rewritten-uri)) + (make-warning package (G_ "URL should be '~a'") + (list rewritten-uri) + #:field 'source))) (let ((origin (package-source package))) (if (and (origin? origin) |