mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-31 14:56:54 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

lint: 'validate-uri' really returns #f on failure.

Browse source 
* guix/scripts/lint.scm (validate-uri): Always return #f on failure.
This commit is contained in:
Ludovic Courtès 2015-05-31 23:13:09 +02:00
parent 1a706ff5cf
commit 91a0b9cc0b
1 changed files with 12 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
guix/scripts/lint.scm
View file

@ -287,20 +287,22 @@ (define response
(values 'unknown-protocol #f))))) (values 'unknown-protocol #f)))))
(define (validate-uri uri package field) (define (validate-uri uri package field)
"Return #t if the given URI can be reached, otherwise emit a "Return #t if the given URI can be reached, otherwise return #f and emit a
warning for PACKAGE mentionning the FIELD." warning for PACKAGE mentionning the FIELD."
(let-values (((status argument) (let-values (((status argument)
(probe-uri uri))) (probe-uri uri)))
(case status (case status
((http-response) ((http-response)
(or (= 200 (response-code argument)) (or (= 200 (response-code argument))
(begin
(emit-warning package (emit-warning package
(format #f (format #f
(_ "URI ~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))
field))) field)
#f)))
((ftp-response) ((ftp-response)
(match argument (match argument
(('ok) #t) (('ok) #t)
@ -309,7 +311,8 @@ (define (validate-uri uri package field)
(format #f (format #f
(_ "URI ~a not reachable: ~a (~s)") (_ "URI ~a not reachable: ~a (~s)")
(uri->string uri) (uri->string uri)
code (string-trim-both message)))))) code (string-trim-both message)))
#f)))
((getaddrinfo-error) ((getaddrinfo-error)
(emit-warning package (emit-warning package
(format #f (format #f