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

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'.
This commit is contained in:
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
;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
;;; 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.
;;;
@ -264,7 +264,7 @@ warning for PACKAGE mentionning the FIELD."
(probe-uri uri)))
(case status
((http-response)
(unless (= 200 (response-code argument))
(or (= 200 (response-code argument))
(emit-warning package
(format #f
(_ "URI ~a not reachable: ~a (~s)")
@ -278,7 +278,8 @@ warning for PACKAGE mentionning the FIELD."
(_ "URI ~a domain not found: ~a")
(uri->string uri)
(gai-strerror (car argument)))
field))
field)
#f)
((system-error)
(emit-warning package
(format #f
@ -287,15 +288,15 @@ warning for PACKAGE mentionning the FIELD."
(strerror
(system-error-errno
(cons status argument))))
field))
field)
#f)
((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))
(error "internal linter error" status)))))
(define (check-home-page package)
"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)
(map string->uri strings)
(list (string->uri strings)))))
(for-each
(cut validate-uri <> package 'source)
(append-map (cut maybe-expand-mirrors <> %mirrors) uris))))))
;; Just make sure that at least one of the URIs is valid.
(any (cut validate-uri <> package 'source)
(append-map (cut maybe-expand-mirrors <> %mirrors)
uris))))))