diff options
author | Mark H Weaver <mhw@netris.org> | 2014-12-30 12:23:32 -0500 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2014-12-30 12:23:32 -0500 |
commit | 8cbb67e04509f0854762269e46a65ee4344388f7 (patch) | |
tree | c44693193709650f19ea3ec264d5ed87170508f0 /guix/scripts | |
parent | 7da473b75721e06237b106c6d186f2729117b1ee (diff) | |
parent | 1c69e4ce3f33242ee8d209b8078fc78a73355446 (diff) | |
download | gnu-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.scm | 121 |
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))) ;;; |