summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-12-28 17:55:16 +0100
committerLudovic Courtès <ludo@gnu.org>2014-12-28 17:57:36 +0100
commita3bf096945b9e429f0fc5e2de4fb537ec5b1a587 (patch)
treea3690c76e82d1b49e710b7629d82bc45d0ff71d5 /guix
parentf9930cfaabe631e2b90f4ee3d30b149f0e3aaae4 (diff)
lint: Add 'home-page' checker.
* guix/build/download.scm (open-connection-for-uri): Export. * guix/scripts/lint.scm (probe-uri, check-home-page): New procedures. (%checkers): Add 'home-page' checker.
Diffstat (limited to 'guix')
-rw-r--r--guix/build/download.scm3
-rw-r--r--guix/scripts/lint.scm106
2 files changed, 108 insertions, 1 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 26b497d458..bb7e4601fd 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -28,7 +28,8 @@
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
- #:export (url-fetch
+ #:export (open-connection-for-uri
+ url-fetch
progress-proc
uri-abbreviation))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index afecd55349..d6aa54dc0c 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)
@@ -201,6 +206,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,6 +398,10 @@ 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))))