03/18: lint: Extract logic of 'check-mirror-url'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit fc5c4ce4ec2ecf6b7d9e227617777d8dd10b903a
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Thu Sep 1 11:01:48 2022 +0200

    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>
---
 guix/gnu-maintenance.scm | 21 +++++++++++++++++++++
 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)