From mboxrd@z Thu Jan 1 00:00:00 1970 From: David Thompson Subject: Re: [PATCH] lint: add 'source' checker. Date: Mon, 29 Dec 2014 08:05:56 -0500 Message-ID: <87r3vili6j.fsf@izanagi.i-did-not-set--mail-host-address--so-tickle-me> References: <54A0C5A8.2030105@gmail.com> <1419824407-6471-1-git-send-email-tipecaml@gmail.com> Mime-Version: 1.0 Content-Type: text/plain Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:43945) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Y5a1I-0005mS-KZ for guix-devel@gnu.org; Mon, 29 Dec 2014 08:06:06 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1Y5a1H-0003cV-7L for guix-devel@gnu.org; Mon, 29 Dec 2014 08:06:00 -0500 Received: from mail.fsf.org ([208.118.235.13]:53202) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Y5a1H-0003cR-4U for guix-devel@gnu.org; Mon, 29 Dec 2014 08:05:59 -0500 In-Reply-To: <1419824407-6471-1-git-send-email-tipecaml@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: Cyril Roelandt , guix-devel@gnu.org Cyril Roelandt writes: > * 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 How about using match instead of case? > + ((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) I think this would be more succint if match-lambda were used instead. > + (catch 'not-available > + (lambda () (uri-available? uri)) > + (lambda (key . args) > + (emit-warning package (car args) 'home-page)))) > + (else > + (error "internal source linter errorl")))) s/errorl/error/ > + 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") s/Valide/Validate/ > + (check check-source)) > + (lint-checker > (name 'synopsis) > (description "Validate package synopses") > (check check-synopsis-style)))) > -- > 1.8.4.rc3 > > Thanks! -- David Thompson Web Developer - Free Software Foundation - http://fsf.org GPG Key: 0FF1D807 Support the FSF: https://fsf.org/donate