From mboxrd@z Thu Jan 1 00:00:00 1970 From: Cyril Roelandt Subject: [PATCH] lint: add 'source' checker. Date: Mon, 29 Dec 2014 04:40:07 +0100 Message-ID: <1419824407-6471-1-git-send-email-tipecaml@gmail.com> References: <54A0C5A8.2030105@gmail.com> Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:58525) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Y5RBr-0000UU-H7 for guix-devel@gnu.org; Sun, 28 Dec 2014 22:40:20 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1Y5RBo-0003is-BM for guix-devel@gnu.org; Sun, 28 Dec 2014 22:40:19 -0500 Received: from mail-wi0-x22d.google.com ([2a00:1450:400c:c05::22d]:47304) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Y5RBo-0003im-0l for guix-devel@gnu.org; Sun, 28 Dec 2014 22:40:16 -0500 Received: by mail-wi0-f173.google.com with SMTP id r20so20947510wiv.0 for ; Sun, 28 Dec 2014 19:40:15 -0800 (PST) In-Reply-To: <54A0C5A8.2030105@gmail.com> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: guix-devel@gnu.org * guix/scripts/lint.scm (uri-available?): New procedure. (%checkers): Add 'home-page' checker --- guix/scripts/lint.scm | 98 ++++++++++++++++++++++++++++++++++----------------- 1 file changed, 65 insertions(+), 33 deletions(-) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 9a0d997..482b3e4 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) @@ -253,45 +254,51 @@ response from URI, and additional details, such as the actual HTTP response." (_ (values 'not-http #f))))) +(define (uri-available? uri) + "Return #t if the given URI can be reached, otherwise throw a +'not-available exception along with an appropriate error message." + (let-values (((status argument) + (probe-uri uri))) + (case status + ((http-response) + (unless (= 200 (response-code argument)) + (throw 'not-available + (format #f + (_ "~a unreachable: ~a (~s)") + (uri->string uri) + (response-code argument) + (response-reason-phrase argument))))) + ((getaddrinfo-error) + (throw 'not-available + (format #f + (_ "domain not found: ~a") + (gai-strerror (car argument))))) + ((system-error) + (throw 'not-available + (format #f + (_ "unreachable: ~a") + (strerror + (system-error-errno + (cons status argument)))))) + ((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))) + #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))))) + (catch 'not-available + (lambda () (uri-available? uri)) + (lambda (key . args) + (emit-warning package (car args) 'home-page)))) ((not (package-home-page package)) (unless (or (string-contains (package-name package) "bootstrap") (string=? (package-name package) "ld-wrapper")) @@ -374,6 +381,27 @@ descriptions maintained upstream." (location->string loc) (package-full-name package) (fill-paragraph (escape-quotes upstream) 77 7))))))) +(define (check-source package) + "" + (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 + (lambda (uri) + (cond + ((uri? uri) + (catch 'not-available + (lambda () (uri-available? uri)) + (lambda (key . args) + (emit-warning package (car args) 'home-page)))) + (else + (error "internal source linter errorl")))) + uris))))) + ;;; ;;; List of checkers. @@ -402,6 +430,10 @@ descriptions maintained upstream." (description "Validate home-page URLs") (check check-home-page)) (lint-checker + (name 'source) + (description "Valide source URLs") + (check check-source)) + (lint-checker (name 'synopsis) (description "Validate package synopses") (check check-synopsis-style)))) -- 1.8.4.rc3