3 files changed, 61 insertions(+), 5 deletions(-)

M doc/guix.texi
M guix/scripts/lint.scm
M tests/lint.scm

@@ 5379,9 5379,11 @@ Identify inputs that should most likely be native inputs.
 
 @item source
 @itemx home-page
+@itemx mirror-url
 @itemx source-file-name
 Probe @code{home-page} and @code{source} URLs and report those that are
-invalid.  Check that the source file name is meaningful, e.g. is not
+invalid.  Suggest a @code{mirror://} URL when applicable.  Check that
+the source file name is meaningful, e.g. is not
 just a version number or ``git-checkout'', without a declared
 @code{file-name} (@pxref{origin Reference}).
 

@@ 65,6 65,7 @@
             check-home-page
             check-source
             check-source-file-name
+            check-mirror-url
             check-license
             check-vulnerabilities
             check-formatting


@@ 567,6 568,14 @@ descriptions maintained upstream."
                  (location->string loc) (package-full-name package)
                  (fill-paragraph (escape-quotes upstream) 77 7)))))))
 
+(define (origin-uris origin)
+  "Return the list of URIs (strings) for ORIGIN."
+  (match (origin-uri origin)
+    ((? string? uri)
+     (list uri))
+    ((uris ...)
+     uris)))
+
 (define (check-source package)
   "Emit a warning if PACKAGE has an invalid 'source' field, or if that
 'source' is not reachable."


@@ 583,10 592,7 @@ descriptions maintained upstream."
   (let ((origin (package-source package)))
     (when (and origin
                (eqv? (origin-method origin) url-fetch))
-      (let* ((strings (origin-uri origin))
-             (uris (if (list? strings)
-                       (map string->uri strings)
-                       (list (string->uri strings)))))
+      (let ((uris (map string->uri (origin-uris origin))))
 
         ;; Just make sure that at least one of the URIs is valid.
         (call-with-values


@@ 626,6 632,31 @@ descriptions maintained upstream."
                     (_ "the source file name should contain the package name")
                     'source))))
 
+(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
+        (()
+         #t)
+        (((mirror-id mirror-urls ...) rest ...)
+         (match (find (cut string-prefix? <> uri) mirror-urls)
+           (#f
+            (loop rest))
+           (prefix
+            (emit-warning package
+                          (format #f (_ "URL should be \
+'mirror://~a/~a'")
+                                  mirror-id
+                                  (string-drop uri (string-length prefix)))
+                          'source)))))))
+
+  (let ((origin (package-source package)))
+    (when (and (origin? origin)
+               (eqv? (origin-method origin) url-fetch))
+      (let ((uris (origin-uris origin)))
+        (for-each check-mirror-uri uris)))))
+
 (define (check-derivation package)
   "Emit a warning if we fail to compile PACKAGE to a derivation."
   (catch #t


@@ 864,6 895,10 @@ or a list thereof")
      (description "Validate source URLs")
      (check       check-source))
    (lint-checker
+     (name        'mirror-url)
+     (description "Suggest 'mirror://' URLs")
+     (check       check-mirror-url))
+   (lint-checker
      (name        'source-file-name)
      (description "Validate file names of sources")
      (check       check-source-file-name))

@@ 508,6 508,25 @@
           (check-source pkg))))
     "not reachable: 404")))
 
+(test-assert "mirror-url"
+  (string-null?
+   (with-warnings
+     (let ((source (origin
+                     (method url-fetch)
+                     (uri "http://example.org/foo/bar.tar.gz")
+                     (sha256 %null-sha256))))
+       (check-mirror-url (dummy-package "x" (source source)))))))
+
+(test-assert "mirror-url: one suggestion"
+  (string-contains
+   (with-warnings
+     (let ((source (origin
+                     (method url-fetch)
+                     (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
+                     (sha256 %null-sha256))))
+       (check-mirror-url (dummy-package "x" (source source)))))
+   "mirror://gnu/foo/foo.tar.gz"))
+
 (test-assert "cve"
   (mock ((guix scripts lint) package-vulnerabilities (const '()))
         (string-null?