Merge branch 'master' into core-updates

3 files changed, 154 insertions, 27 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 26b497d458..5928ccd154 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -28,7 +28,9 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
-  #:export (url-fetch
+  #:export (open-connection-for-uri
+            maybe-expand-mirrors
+            url-fetch
             progress-proc
             uri-abbreviation))
 
@@ -278,32 +280,34 @@ which is not available during bootstrap."
     (lambda (key . args)
       (print-exception (current-error-port) #f key args))))
 
+(define (uri-vicinity dir file)
+  "Concatenate DIR, slash, and FILE, keeping only one slash in between.
+This is required by some HTTP servers."
+  (string-append (string-trim-right dir #\/) "/"
+                 (string-trim file #\/)))
+
+(define (maybe-expand-mirrors uri mirrors)
+  "If URI uses the 'mirror' scheme, expand it according to the MIRRORS alist.
+Return a list of URIs."
+  (case (uri-scheme uri)
+    ((mirror)
+     (let ((kind (string->symbol (uri-host uri)))
+           (path (uri-path uri)))
+       (match (assoc-ref mirrors kind)
+         ((mirrors ..1)
+          (map (compose string->uri (cut uri-vicinity <> path))
+               mirrors))
+         (_
+          (error "unsupported URL mirror kind" kind uri)))))
+    (else
+     (list uri))))
+
 (define* (url-fetch url file #:key (mirrors '()))
   "Fetch FILE from URL; URL may be either a single string, or a list of
 string denoting alternate URLs for FILE.  Return #f on failure, and FILE
 on success."
-  (define (uri-vicinity dir file)
-    ;; Concatenate DIR, slash, and FILE, keeping only one slash in between.
-    ;; This is required by some HTTP servers.
-    (string-append (string-trim-right dir #\/) "/"
-                   (string-trim file #\/)))
-
-  (define (maybe-expand-mirrors uri)
-    (case (uri-scheme uri)
-      ((mirror)
-       (let ((kind (string->symbol (uri-host uri)))
-             (path (uri-path uri)))
-         (match (assoc-ref mirrors kind)
-           ((mirrors ..1)
-            (map (compose string->uri (cut uri-vicinity <> path))
-                 mirrors))
-           (_
-            (error "unsupported URL mirror kind" kind uri)))))
-      (else
-       (list uri))))
-
   (define uri
-    (append-map maybe-expand-mirrors
+    (append-map (cut maybe-expand-mirrors <> mirrors)
                 (match url
                   ((_ ...) (map string->uri url))
                   (_       (list (string->uri url))))))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index afecd55349..15ae213339 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -29,6 +29,11 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
+  #:use-module (web uri)
+  #:use-module ((guix build download)
+                #:select (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)
@@ -37,7 +42,8 @@
             check-description-style
             check-inputs-should-be-native
             check-patches
-            check-synopsis-style))
+            check-synopsis-style
+            check-home-page))
 
 
 ;;;
@@ -201,6 +207,103 @@ the synopsis")
      (check-start-with-package-name synopsis)
      (check-synopsis-length synopsis))))
 
+(define (probe-uri uri)
+  "Probe URI, a URI object, and return two values: a symbol denoting the
+probing status, such as 'http-response' when we managed to get an HTTP
+response from URI, and additional details, such as the actual HTTP response."
+  (define headers
+    '((User-Agent . "GNU Guile")
+      (Accept . "*/*")))
+
+  (let loop ((uri     uri)
+             (visited '()))
+    (match (uri-scheme uri)
+      ((or 'http 'https)
+       (catch #t
+         (lambda ()
+           (let ((port    (open-connection-for-uri uri))
+                 (request (build-request uri #:headers headers)))
+             (define response
+               (dynamic-wind
+                 (const #f)
+                 (lambda ()
+                   (write-request request port)
+                   (force-output port)
+                   (read-response port))
+                 (lambda ()
+                   (close port))))
+
+             (case (response-code response)
+               ((301 302 307)
+                (let ((location (response-location response)))
+                  (if (or (not location) (member location visited))
+                      (values 'http-response response)
+                      (loop location (cons location visited))))) ;follow the redirect
+               (else
+                (values 'http-response response)))))
+         (lambda (key . args)
+           (case key
+             ((bad-header bad-header-component)
+              ;; This can happen if the server returns an invalid HTTP header,
+              ;; as is the case with the 'Date' header at sqlite.org.
+              (values 'invalid-http-response #f))
+             ((getaddrinfo-error system-error gnutls-error)
+              (values key args))
+             (else
+              (apply throw key args))))))
+      (_
+       (values 'not-http #f)))))
+
+(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)))))
+     ((not (package-home-page package))
+      (unless (or (string-contains (package-name package) "bootstrap")
+                  (string=? (package-name package) "ld-wrapper"))
+        (emit-warning package
+                      (_ "invalid value for home page")
+                      'home-page)))
+     (else
+      (emit-warning package (format #f (_ "invalid home page URL: ~s")
+                                    (package-home-page package))
+                    'home-page)))))
+
 (define (check-patches package)
   ;; Emit a warning if the patches requires by PACKAGE are badly named.
   (let ((patches   (and=> (package-source package) origin-patches))
@@ -296,15 +399,25 @@ descriptions maintained upstream."
      (description "Validate file names of patches")
      (check       check-patches))
    (lint-checker
+     (name        'home-page)
+     (description "Validate home-page URLs")
+     (check       check-home-page))
+   (lint-checker
      (name        'synopsis)
      (description "Validate package synopses")
      (check       check-synopsis-style))))
 
 (define (run-checkers package checkers)
   ;; Run the given CHECKERS on PACKAGE.
-  (for-each (lambda (checker)
-              ((lint-checker-check checker) package))
-            checkers))
+  (let ((tty? (isatty? (current-error-port)))
+        (name (package-full-name package)))
+    (for-each (lambda (checker)
+                (when tty?
+                  (format (current-error-port) "checking ~a [~a]...\r"
+                          name (lint-checker-name checker))
+                  (force-output (current-error-port)))
+                ((lint-checker-check checker) package))
+              checkers)))
 
 
 ;;;
diff --git a/guix/tests.scm b/guix/tests.scm
index 022679902a..82ae7e2084 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -27,7 +27,8 @@
   #:export (open-connection-for-tests
             random-text
             random-bytevector
-            with-derivation-narinfo))
+            with-derivation-narinfo
+            dummy-package))
 
 ;;; Commentary:
 ;;;
@@ -120,6 +121,15 @@ substituter's viewpoint."
     (lambda ()
       body ...)))
 
+(define-syntax-rule (dummy-package name* extra-fields ...)
+  "Return a \"dummy\" package called NAME*, with all its compulsory fields
+initialized with default values, and with EXTRA-FIELDS set as specified."
+  (package extra-fields ...
+           (name name*) (version "0") (source #f)
+           (build-system gnu-build-system)
+           (synopsis #f) (description #f)
+           (home-page #f) (license #f)))
+
 ;; Local Variables:
 ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
 ;; End: