guix lint: Make the 'source' checker happy if at least one URI is valid.

Before that it would check all the URIs of each package.

* guix/scripts/lint.scm (validate-uri): Really return #f on failure and
  #t otherwise.
  (check-source): Replace 'for-each' with 'any'.

1 files changed, 18 insertions, 16 deletions

diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index eb0c9f7da0..229b73702e 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -264,21 +264,22 @@ warning for PACKAGE mentionning the FIELD."
                 (probe-uri uri)))
     (case status
       ((http-response)
-       (unless (= 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)))
+       (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)))
       ((getaddrinfo-error)
        (emit-warning package
                      (format #f
                              (_ "URI ~a domain not found: ~a")
                              (uri->string uri)
                              (gai-strerror (car argument)))
-                     field))
+                     field)
+       #f)
       ((system-error)
        (emit-warning package
                      (format #f
@@ -287,15 +288,15 @@ warning for PACKAGE mentionning the FIELD."
                              (strerror
                               (system-error-errno
                                (cons status argument))))
-                     field))
+                     field)
+       #f)
       ((invalid-http-response gnutls-error)
        ;; Probably a misbehaving server; ignore.
        #f)
       ((not-http)                             ;nothing we can do
        #f)
       (else
-       (error "internal linter error" status)))
-    #t))
+       (error "internal linter error" status)))))
 
 (define (check-home-page package)
   "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
@@ -396,9 +397,10 @@ descriptions maintained upstream."
              (uris (if (list? strings)
                        (map string->uri strings)
                        (list (string->uri strings)))))
-       (for-each
-         (cut validate-uri <> package 'source)
-         (append-map (cut maybe-expand-mirrors <> %mirrors) uris))))))
+        ;; 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))))))