summaryrefslogtreecommitdiff
path: root/guix/scripts/lint.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/lint.scm')
-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 be29e36ce1..9b991786c3 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -67,6 +67,7 @@
check-home-page
check-source
check-source-file-name
+ check-mirror-url
check-license
check-vulnerabilities
check-formatting
@@ -600,6 +601,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."
@@ -616,10 +625,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
@@ -659,6 +665,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
@@ -901,6 +932,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))