From 17a7b75c0f727cd7c32b156d8a9235a2009a248f Mon Sep 17 00:00:00 2001
From: Cyril Roelandt <tipecaml@gmail.com>
Date: Mon, 29 Dec 2014 04:38:15 +0100
Subject: lint: add 'source' checker.

* guix/scripts/lint.scm (validate-uri?): New procedure.
  (%checkers): Add 'source' checker
---
 guix/scripts/lint.scm | 98 +++++++++++++++++++++++++++++++++------------------
 1 file changed, 64 insertions(+), 34 deletions(-)

diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 15ae213339..eb0c9f7da0 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)
@@ -31,12 +32,14 @@ (define-module (guix scripts lint)
   #:use-module (ice-9 format)
   #:use-module (web uri)
   #:use-module ((guix build download)
-                #:select (open-connection-for-uri))
+                #:select (maybe-expand-mirrors
+                          open-connection-for-uri))
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:export (guix-lint
             check-description-style
@@ -254,45 +257,53 @@ (define response
       (_
        (values 'not-http #f)))))
 
+(define (validate-uri uri package field)
+  "Return #t if the given URI can be reached, otherwise emit a
+warning for PACKAGE mentionning the FIELD."
+  (let-values (((status argument)
+                (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)))
+      ((getaddrinfo-error)
+       (emit-warning package
+                     (format #f
+                             (_ "URI ~a domain not found: ~a")
+                             (uri->string uri)
+                             (gai-strerror (car argument)))
+                     field))
+      ((system-error)
+       (emit-warning package
+                     (format #f
+                             (_ "URI ~a unreachable: ~a")
+                             (uri->string uri)
+                             (strerror
+                              (system-error-errno
+                               (cons status argument))))
+                     field))
+      ((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))
+
 (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)))))
+      (validate-uri uri package 'home-page))
      ((not (package-home-page package))
       (unless (or (string-contains (package-name package) "bootstrap")
                   (string=? (package-name package) "ld-wrapper"))
@@ -375,6 +386,21 @@ (define (check-gnu-synopsis+description package)
                  (location->string loc) (package-full-name package)
                  (fill-paragraph (escape-quotes upstream) 77 7)))))))
 
+(define (check-source package)
+  "Emit a warning if PACKAGE has an invalid 'source' field, or if that
+'source' is not reachable."
+  (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
+         (cut validate-uri <> package 'source)
+         (append-map (cut maybe-expand-mirrors <> %mirrors) uris))))))
+
+
 
 ;;;
 ;;; List of checkers.
@@ -402,6 +428,10 @@ (define %checkers
      (name        'home-page)
      (description "Validate home-page URLs")
      (check       check-home-page))
+   (lint-checker
+     (name        'source)
+     (description "Validate source URLs")
+     (check       check-source))
    (lint-checker
      (name        'synopsis)
      (description "Validate package synopses")
-- 
cgit v1.2.3