summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2014-12-30 12:23:32 -0500
committerMark H Weaver <mhw@netris.org>2014-12-30 12:23:32 -0500
commit8cbb67e04509f0854762269e46a65ee4344388f7 (patch)
treec44693193709650f19ea3ec264d5ed87170508f0 /guix/scripts
parent7da473b75721e06237b106c6d186f2729117b1ee (diff)
parent1c69e4ce3f33242ee8d209b8078fc78a73355446 (diff)
downloadgnu-guix-8cbb67e04509f0854762269e46a65ee4344388f7.tar
gnu-guix-8cbb67e04509f0854762269e46a65ee4344388f7.tar.gz
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/lint.scm121
1 files changed, 117 insertions, 4 deletions
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)))
;;;