From mboxrd@z Thu Jan 1 00:00:00 1970 From: Cyril Roelandt Subject: [PATCHv2] lint: add 'source' checker. Date: Thu, 15 Jan 2015 08:52:45 +0100 Message-ID: <1421308365-15655-1-git-send-email-tipecaml@gmail.com> References: <1419824407-6471-1-git-send-email-tipecaml@gmail.com> Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:53076) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YBfEj-0000Nb-NR for guix-devel@gnu.org; Thu, 15 Jan 2015 02:53:02 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1YBfEg-0002p9-Gl for guix-devel@gnu.org; Thu, 15 Jan 2015 02:53:01 -0500 Received: from mail-wg0-x233.google.com ([2a00:1450:400c:c00::233]:40845) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YBfEg-0002mv-5N for guix-devel@gnu.org; Thu, 15 Jan 2015 02:52:58 -0500 Received: by mail-wg0-f51.google.com with SMTP id x12so13214792wgg.10 for ; Wed, 14 Jan 2015 23:52:57 -0800 (PST) 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: guix-devel@gnu.org * guix/scripts/lint.scm (validate-uri?): New procedure. (%checkers): Add 'home-page' checker --- guix/scripts/lint.scm | 102 +++++++++++++++++++++++++++++++++----------------- 1 file changed, 68 insertions(+), 34 deletions(-) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 15ae213..7a0b246 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) @@ -31,7 +32,8 @@ #:use-module (ice-9 format) #:use-module (web uri) #:use-module ((guix build download) - #:select (open-connection-for-uri)) + #:select (maybe-expand-mirrors + open-connection-for-uri)) #:use-module (web request) #:use-module (web response) #:use-module (srfi srfi-1) @@ -254,45 +256,53 @@ response from URI, and additional details, such as the actual HTTP response." (_ (values 'not-http #f))))) +(define (validate-uri uri package field) + "Return #t if the given URI can be reached, otherwise emit a +warning for PACKAGE mentionning the FIELD." + (let-values (((status argument) + (probe-uri uri))) + (case status + ((http-response) + (unless (= 200 (response-code argument)) + (emit-warning package + (format #f + (_ "URI ~a not reachable: ~a (~s)") + (uri->string uri) + (response-code argument) + (response-reason-phrase argument)) + field))) + ((getaddrinfo-error) + (emit-warning package + (format #f + (_ "URI ~a domain not found: ~a") + (uri->string uri) + (gai-strerror (car argument))) + field)) + ((system-error) + (emit-warning package + (format #f + (_ "URI ~a unreachable: ~a") + (uri->string uri) + (strerror + (system-error-errno + (cons status argument)))) + field)) + ((invalid-http-response gnutls-error) + ;; Probably a misbehaving server; ignore. + #f) + ((not-http) ;nothing we can do + #f) + (else + (error "internal 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))))) + (validate-uri uri package 'home-page)) ((not (package-home-page package)) (unless (or (string-contains (package-name package) "bootstrap") (string=? (package-name package) "ld-wrapper")) @@ -375,6 +385,26 @@ descriptions maintained upstream." (location->string loc) (package-full-name package) (fill-paragraph (escape-quotes upstream) 77 7))))))) +(define (check-source package) + "Emit a warning if PACKAGE has an invalid 'source' field, or if that +'source' is not reachable." + (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 + (match-lambda + ((? uri? uri) + (validate-uri uri package 'source)) + (_ (error "internal linter error"))) + (concatenate (map (lambda (uri) + (maybe-expand-mirrors uri %mirrors)) + uris))))))) + + ;;; ;;; List of checkers. @@ -403,6 +433,10 @@ descriptions maintained upstream." (description "Validate home-page URLs") (check check-home-page)) (lint-checker + (name 'source) + (description "Validate source URLs") + (check check-source)) + (lint-checker (name 'synopsis) (description "Validate package synopses") (check check-synopsis-style)))) -- 1.8.4.rc3