summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-11-19 18:06:46 +0100
committerLudovic Courtès <ludo@gnu.org>2016-11-19 18:44:53 +0100
commitfac46e3f5e55f9de6fa2ab8082bc418139590fc0 (patch)
treedc7c03992475f5826a6fa948edf8705feff787d0 /guix/scripts
parente74f64b9e55cbc3052698830001238d2407fed19 (diff)
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.
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/lint.scm43
1 files changed, 39 insertions, 4 deletions
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
@@ -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))