From 2b5115f8ba62f3d36f39c0c6ee3b49fbc04e986a Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 31 May 2015 23:22:29 +0200
Subject: 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.
---
 guix/scripts/lint.scm | 51 ++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file 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."
-- 
cgit 1.4.1