03/05: lint: Add 'mirror-url' checker.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit fac46e3f5e55f9de6fa2ab8082bc418139590fc0
Author: Ludovic Courtès <address@hidden>
Date:   Sat Nov 19 18:06:46 2016 +0100

    lint: Add 'mirror-url' checker.
    
    * guix/scripts/lint.scm (origin-uris): New procedure.
    (check-source): Use it.
    (check-mirror-url): New procedure.
    (%checkers): Add 'mirror-url' checker.
    * tests/lint.scm ("mirror-url")
    ("mirror-url: one suggestion"): New tests.
    * doc/guix.texi (Invoking guix lint): Document it.
---
 doc/guix.texi         |    4 +++-
 guix/scripts/lint.scm |   43 +++++++++++++++++++++++++++++++++++++++----
 tests/lint.scm        |   19 +++++++++++++++++++
 3 files changed, 61 insertions(+), 5 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 0e70830..7352ea9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5379,9 +5379,11 @@ Identify inputs that should most likely be native inputs.
 
 @item source
 @itemx home-page
address@hidden 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}).
 
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 6e6f550..9641d39 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -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))
diff --git a/tests/lint.scm b/tests/lint.scm
index cf1b95e..0c53456 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -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?