[PATCH] lint: add 'source' checker.

[Cyril Roelandt <tipecaml@gmail.com>]

* guix/scripts/lint.scm (uri-available?): New procedure.
  (%checkers): Add 'home-page' checker
---
 guix/scripts/lint.scm | 98 ++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 65 insertions(+), 33 deletions(-)

diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 9a0d997..482b3e4 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -20,6 +20,7 @@
 
 (define-module (guix scripts lint)
   #:use-module (guix base32)
+  #:use-module (guix download)
   #:use-module (guix packages)
   #:use-module (guix records)
   #:use-module (guix ui)
@@ -253,45 +254,51 @@ response from URI, and additional details, such as the actual HTTP response."
       (_
        (values 'not-http #f)))))
 
+(define (uri-available? uri)
+  "Return #t if the given URI can be reached, otherwise throw a
+'not-available exception along with an appropriate error message."
+  (let-values (((status argument)
+                (probe-uri uri)))
+    (case status
+      ((http-response)
+       (unless (= 200 (response-code argument))
+         (throw 'not-available
+                (format #f
+                        (_ "~a unreachable: ~a (~s)")
+                        (uri->string uri)
+                        (response-code argument)
+                        (response-reason-phrase argument)))))
+      ((getaddrinfo-error)
+       (throw 'not-available
+              (format #f
+                      (_ "domain not found: ~a")
+                      (gai-strerror (car argument)))))
+      ((system-error)
+       (throw 'not-available
+              (format #f
+                      (_ "unreachable: ~a")
+                      (strerror
+                       (system-error-errno
+                        (cons status argument))))))
+      ((invalid-http-response gnutls-error)
+       ;; Probably a misbehaving server; ignore.
+       #f)
+      ((not-http)                             ;nothing we can do
+       #f)
+      (else
+       (error "internal home-page linter error" status)))
+    #t))
+
 (define (check-home-page package)
   "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
 'home-page' is not reachable."
   (let ((uri (and=> (package-home-page package) string->uri)))
     (cond
      ((uri? uri)
-      (let-values (((status argument)
-                    (probe-uri uri)))
-        (case status
-          ((http-response)
-           (unless (= 200 (response-code argument))
-             (emit-warning package
-                           (format #f
-                                   (_ "home page ~a not reachable: ~a (~s)")
-                                   (uri->string uri)
-                                   (response-code argument)
-                                   (response-reason-phrase argument))
-                           'home-page)))
-          ((getaddrinfo-error)
-           (emit-warning package
-                         (format #f
-                                 (_ "home page domain not found: ~a")
-                                 (gai-strerror (car argument)))
-                         'package))
-          ((system-error)
-           (emit-warning package
-                         (format #f
-                                 (_ "home page unreachable: ~a")
-                                 (strerror
-                                  (system-error-errno
-                                   (cons status argument))))
-                         'home-page))
-          ((invalid-http-response gnutls-error)
-           ;; Probably a misbehaving server; ignore.
-           #f)
-          ((not-http)                             ;nothing we can do
-           #f)
-          (else
-           (error "internal home-page linter error" status)))))
+      (catch 'not-available
+             (lambda () (uri-available? uri))
+             (lambda (key . args)
+               (emit-warning package (car args) 'home-page))))
      ((not (package-home-page package))
       (unless (or (string-contains (package-name package) "bootstrap")
                   (string=? (package-name package) "ld-wrapper"))
@@ -374,6 +381,27 @@ descriptions maintained upstream."
                  (location->string loc) (package-full-name package)
                  (fill-paragraph (escape-quotes upstream) 77 7)))))))
 
+(define (check-source package)
+  ""
+  (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)))))
+       (for-each
+         (lambda (uri)
+           (cond
+            ((uri? uri)
+             (catch 'not-available
+                    (lambda () (uri-available? uri))
+                    (lambda (key . args)
+                      (emit-warning package (car args) 'home-page))))
+            (else
+              (error "internal source linter errorl"))))
+         uris)))))
+
 \f
 ;;;
 ;;; List of checkers.
@@ -402,6 +430,10 @@ descriptions maintained upstream."
      (description "Validate home-page URLs")
      (check       check-home-page))
    (lint-checker
+     (name        'source)
+     (description "Valide source URLs")
+     (check       check-source))
+   (lint-checker
      (name        'synopsis)
      (description "Validate package synopses")
      (check       check-synopsis-style))))
-- 
1.8.4.rc3