diff options
Diffstat (limited to 'guix/scripts/lint.scm')
| -rw-r--r-- | guix/scripts/lint.scm | 75 |
1 files changed, 62 insertions, 13 deletions
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index cced1bda66..3740b71d5e 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 @@ -287,20 +308,22 @@ response from URI, and additional details, such as the actual HTTP response." (values 'unknown-protocol #f))))) (define (validate-uri uri package field) - "Return #t if the given URI can be reached, otherwise emit a + "Return #t if the given URI can be reached, otherwise return #f and emit a warning for PACKAGE mentionning the FIELD." (let-values (((status argument) (probe-uri uri))) (case status ((http-response) (or (= 200 (response-code argument)) - (emit-warning package - (format #f - (_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - (response-code argument) - (response-reason-phrase argument)) - field))) + (begin + (emit-warning package + (format #f + (_ "URI ~a not reachable: ~a (~s)") + (uri->string uri) + (response-code argument) + (response-reason-phrase argument)) + field) + #f))) ((ftp-response) (match argument (('ok) #t) @@ -309,7 +332,8 @@ warning for PACKAGE mentionning the FIELD." (format #f (_ "URI ~a not reachable: ~a (~s)") (uri->string uri) - code (string-trim-both message)))))) + code (string-trim-both message))) + #f))) ((getaddrinfo-error) (emit-warning package (format #f @@ -432,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)) @@ -439,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." @@ -527,7 +575,8 @@ descriptions maintained upstream." (define (show-help) (display (_ "Usage: guix lint [OPTION]... [PACKAGE]... -Run a set of checkers on the specified package; if none is specified, run the checkers on all packages.\n")) +Run a set of checkers on the specified package; if none is specified, +run the checkers on all packages.\n")) (display (_ " -c, --checkers=CHECKER1,CHECKER2... only run the specificed checkers")) |