aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-05-31 23:22:29 +0200
committerLudovic Courtès <ludo@gnu.org>2015-05-31 23:25:46 +0200
commit2b5115f8ba62f3d36f39c0c6ee3b49fbc04e986a (patch)
tree9d08a827f4fa5853635b0053593c9975dd38c0eb
parent91a0b9cc0bd60864aac43ca137d66f3aea1f92b3 (diff)
downloadguix-2b5115f8ba62f3d36f39c0c6ee3b49fbc04e986a.tar
guix-2b5115f8ba62f3d36f39c0c6ee3b49fbc04e986a.tar.gz
lint: source: Warn only when all the URIs are unreachable.
* guix/scripts/lint.scm (call-with-accumulated-warnings): New procedure. (with-accumulated-warnings): New macro. (check-source): Add 'try-uris' and use it. Emit warnings only upon failure.
-rw-r--r--guix/scripts/lint.scm51
1 files changed, 48 insertions, 3 deletions
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index b04e39997e..3b139ce6b2 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -28,6 +28,7 @@
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix gnu-maintenance)
+ #:use-module (guix monads)
#:use-module (gnu packages)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
@@ -41,6 +42,7 @@
#:use-module (web request)
#:use-module (web response)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-6) ;Unicode string ports
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
@@ -71,6 +73,25 @@
(package-full-name package)
message)))
+(define (call-with-accumulated-warnings thunk)
+ "Call THUNK, accumulating any warnings in the current state, using the state
+monad."
+ (let ((port (open-output-string)))
+ (mlet %state-monad ((state (current-state))
+ (result -> (parameterize ((guix-warning-port port))
+ (thunk)))
+ (warning -> (get-output-string port)))
+ (mbegin %state-monad
+ (munless (string=? "" warning)
+ (set-current-state (cons warning state)))
+ (return result)))))
+
+(define-syntax-rule (with-accumulated-warnings exp ...)
+ "Evaluate EXP and accumulate warnings in the state monad."
+ (call-with-accumulated-warnings
+ (lambda ()
+ exp ...)))
+
;;;
;;; Checkers
@@ -435,6 +456,16 @@ descriptions maintained upstream."
(define (check-source package)
"Emit a warning if PACKAGE has an invalid 'source' field, or if that
'source' is not reachable."
+ (define (try-uris uris)
+ (run-with-state
+ (anym %state-monad
+ (lambda (uri)
+ (with-accumulated-warnings
+ (validate-uri uri package 'source)))
+ (append-map (cut maybe-expand-mirrors <> %mirrors)
+ uris))
+ '()))
+
(let ((origin (package-source package)))
(when (and origin
(eqv? (origin-method origin) url-fetch))
@@ -442,10 +473,24 @@ descriptions maintained upstream."
(uris (if (list? strings)
(map string->uri strings)
(list (string->uri strings)))))
+
;; Just make sure that at least one of the URIs is valid.
- (any (cut validate-uri <> package 'source)
- (append-map (cut maybe-expand-mirrors <> %mirrors)
- uris))))))
+ (call-with-values
+ (lambda () (try-uris uris))
+ (lambda (success? warnings)
+ ;; When everything fails, report all of WARNINGS, otherwise don't
+ ;; report anything.
+ ;;
+ ;; XXX: Ideally we'd still allow warnings to be raised if *some*
+ ;; URIs are unreachable, but distinguish that from the error case
+ ;; where *all* the URIs are unreachable.
+ (unless success?
+ (emit-warning package
+ (_ "all the source URIs are unreachable:")
+ 'source)
+ (for-each (lambda (warning)
+ (display warning (guix-warning-port)))
+ (reverse warnings)))))))))
(define (check-derivation package)
"Emit a warning if we fail to compile PACKAGE to a derivation."