@@ -2,6 +2,7 @@
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -32,6 +33,8 @@ (define-module (guix gnu-maintenance)
#: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)
@@ -57,6 +60,8 @@ (define-module (guix gnu-maintenance)
find-package
gnu-package?
+ uri-mirror-rewrite
+
release-file?
releases
latest-release
@@ -651,6 +656,24 @@ (define (url-prefix-rewrite old new)
(string-append new (string-drop url (string-length old)))
url)))
+(define (uri-mirror-rewrite uri)
+ "Rewrite URI to a mirror:// URI if possible. When not, return URI unmodified."
+ (if (string-prefix? "mirror://" uri)
+ ;; Nothing to do, it's already a mirror URI!
+ 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
@@ -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.
@@ -1223,21 +1223,12 @@ (define (check-source-uri uri)
(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 maybe-rewritten-uri (uri-mirror-rewrite uri))
+ (and (not (eq? uri maybe-rewritten-uri))
+ (make-warning package
+ (G_ "URL should be '~a'")
+ (list maybe-rewritten-uri)
+ #:field 'source)))
(let ((origin (package-source package)))
(if (and (origin? origin)