From fac46e3f5e55f9de6fa2ab8082bc418139590fc0 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 19 Nov 2016 18:06:46 +0100
Subject: 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.
---
 guix/scripts/lint.scm | 43 +++++++++++++++++++++++++++++++++++++++----
 1 file changed, 39 insertions(+), 4 deletions(-)

(limited to 'guix/scripts/lint.scm')

diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 6e6f550941..9641d3926a 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
@@ -863,6 +894,10 @@ or a list thereof")
      (name        'source)
      (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")
-- 
cgit v1.2.3