me
/
guix
Archived
1
0
Fork 0
Code

guix lint: Make the 'source' checker happy if at least one URI is valid. 

Before that it would check all the URIs of each package.

* guix/scripts/lint.scm (validate-uri): Really return #f on failure and
  #t otherwise.
  (check-source): Replace 'for-each' with 'any'.
master
Ludovic Courtès 2015-01-26 00:19:04 +01:00
parent ac41737f49
commit 06aac933e1
1 changed files with 18 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
guix/scripts/lint.scm
View File

@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -264,7 +264,7 @@ warning for PACKAGE mentionning the FIELD."
(probe-uri uri))) (probe-uri uri)))
(case status (case status
((http-response) ((http-response)
(unless (= 200 (response-code argument)) (or (= 200 (response-code argument))
(emit-warning package (emit-warning package
(format #f (format #f
(_ "URI ~a not reachable: ~a (~s)") (_ "URI ~a not reachable: ~a (~s)")
@ -278,7 +278,8 @@ warning for PACKAGE mentionning the FIELD."
(_ "URI ~a domain not found: ~a") (_ "URI ~a domain not found: ~a")
(uri->string uri) (uri->string uri)
(gai-strerror (car argument))) (gai-strerror (car argument)))
field)) field)
#f)
((system-error) ((system-error)
(emit-warning package (emit-warning package
(format #f (format #f
@ -287,15 +288,15 @@ warning for PACKAGE mentionning the FIELD."
(strerror (strerror
(system-error-errno (system-error-errno
(cons status argument)))) (cons status argument))))
field)) field)
#f)
((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 linter error" status))) (error "internal linter error" status)))))
#t))
(define (check-home-page package) (define (check-home-page package)
"Emit a warning if PACKAGE has an invalid 'home-page' field, or if that "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
@ -396,9 +397,10 @@ descriptions maintained upstream."
(uris (if (list? strings) (uris (if (list? strings)
(map string->uri strings) (map string->uri strings)
(list (string->uri strings))))) (list (string->uri strings)))))
(for-each ;; Just make sure that at least one of the URIs is valid.
(cut validate-uri <> package 'source) (any (cut validate-uri <> package 'source)
(append-map (cut maybe-expand-mirrors <> %mirrors) uris)))))) (append-map (cut maybe-expand-mirrors <> %mirrors)
uris))))))