nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

lint: add 'source' checker. 

* guix/scripts/lint.scm (validate-uri?): New procedure.
  (%checkers): Add 'source' checker
This commit is contained in:
Cyril Roelandt 2014-12-29 04:38:15 +01:00
parent 03c2776535
commit 17a7b75c0f
1 changed files with 64 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
guix/scripts/lint.scm
View File

@ -20,6 +20,7 @@
(define-module (guix scripts lint) (define-module (guix scripts lint)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix download)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix ui) #:use-module (guix ui)
@ -31,12 +32,14 @@
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (web uri) #:use-module (web uri)
#:use-module ((guix build download) #: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 request)
#:use-module (web response) #:use-module (web response)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:export (guix-lint #:export (guix-lint
check-description-style check-description-style
@ -254,12 +257,9 @@ response from URI, and additional details, such as the actual HTTP response."
(_ (_
(values 'not-http #f))))) (values 'not-http #f)))))
(define (check-home-page package) (define (validate-uri uri package field)
"Emit a warning if PACKAGE has an invalid 'home-page' field, or if that "Return #t if the given URI can be reached, otherwise emit a
'home-page' is not reachable." warning for PACKAGE mentionning the FIELD."
(let ((uri (and=> (package-home-page package) string->uri)))
(cond
((uri? uri)
(let-values (((status argument) (let-values (((status argument)
(probe-uri uri))) (probe-uri uri)))
(case status (case status
@ -267,32 +267,43 @@ response from URI, and additional details, such as the actual HTTP response."
(unless (= 200 (response-code argument)) (unless (= 200 (response-code argument))
(emit-warning package (emit-warning package
(format #f (format #f
(_ "home page ~a not reachable: ~a (~s)") (_ "URI ~a not reachable: ~a (~s)")
(uri->string uri) (uri->string uri)
(response-code argument) (response-code argument)
(response-reason-phrase argument)) (response-reason-phrase argument))
'home-page))) field)))
((getaddrinfo-error) ((getaddrinfo-error)
(emit-warning package (emit-warning package
(format #f (format #f
(_ "home page domain not found: ~a") (_ "URI ~a domain not found: ~a")
(uri->string uri)
(gai-strerror (car argument))) (gai-strerror (car argument)))
'package)) field))
((system-error) ((system-error)
(emit-warning package (emit-warning package
(format #f (format #f
(_ "home page unreachable: ~a") (_ "URI ~a unreachable: ~a")
(uri->string uri)
(strerror (strerror
(system-error-errno (system-error-errno
(cons status argument)))) (cons status argument))))
'home-page)) field))
((invalid-http-response gnutls-error) ((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore. ;; Probably a misbehaving server; ignore.
#f) #f)
((not-http) ;nothing we can do ((not-http) ;nothing we can do
#f) #f)
(else (else
(error "internal home-page linter error" status))))) (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)
(validate-uri uri package 'home-page))
((not (package-home-page package)) ((not (package-home-page package))
(unless (or (string-contains (package-name package) "bootstrap") (unless (or (string-contains (package-name package) "bootstrap")
(string=? (package-name package) "ld-wrapper")) (string=? (package-name package) "ld-wrapper"))
@ -375,6 +386,21 @@ descriptions maintained upstream."
(location->string loc) (package-full-name package) (location->string loc) (package-full-name package)
(fill-paragraph (escape-quotes upstream) 77 7))))))) (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
(cut validate-uri <> package 'source)
(append-map (cut maybe-expand-mirrors <> %mirrors) uris))))))
;;; ;;;
;;; List of checkers. ;;; List of checkers.
@ -402,6 +428,10 @@ descriptions maintained upstream."
(name 'home-page) (name 'home-page)
(description "Validate home-page URLs") (description "Validate home-page URLs")
(check check-home-page)) (check check-home-page))
(lint-checker
(name 'source)
(description "Validate source URLs")
(check check-source))
(lint-checker (lint-checker
(name 'synopsis) (name 'synopsis)
(description "Validate package synopses") (description "Validate package synopses")