guix/guix
3
5
Fork 0
mirror of git://git.savannah.gnu.org/guix.git synced 2023-12-14 03:33:07 +01:00
Code Issues Releases Wiki Activity

lint: Have connections time out after 3 seconds.

Browse source 
* guix/scripts/lint.scm (probe-uri): Add #:timeout parameter.  Pass it
  to 'open-connection-for-uri' and 'ftp-open'.
  (validate-uri): Pass #:timeout 3 to 'probe-uri'.
This commit is contained in:
Ludovic Courtès 2015-11-12 23:17:12 +01:00
parent 1b9aefa394
commit bd7e1ffae6
1 changed files with 8 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
guix/scripts/lint.scm
View file

@ -266,10 +266,13 @@ the synopsis")
(check-start-with-package-name synopsis) (check-start-with-package-name synopsis)
(check-synopsis-length synopsis)))) (check-synopsis-length synopsis))))
(define (probe-uri uri) (define* (probe-uri uri #:key timeout)
"Probe URI, a URI object, and return two values: a symbol denoting the "Probe URI, a URI object, and return two values: a symbol denoting the
probing status, such as 'http-response' when we managed to get an HTTP probing status, such as 'http-response' when we managed to get an HTTP
response from URI, and additional details, such as the actual HTTP response." response from URI, and additional details, such as the actual HTTP response.
TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait
for connections to complete; when TIMEOUT is #f, wait as long as needed."
(define headers (define headers
'((User-Agent . "GNU Guile") '((User-Agent . "GNU Guile")
(Accept . "*/*"))) (Accept . "*/*")))
@ -280,7 +283,7 @@ response from URI, and additional details, such as the actual HTTP response."
((or 'http 'https) ((or 'http 'https)
(catch #t (catch #t
(lambda () (lambda ()
(let ((port (open-connection-for-uri uri)) (let ((port (open-connection-for-uri uri #:timeout timeout))
(request (build-request uri #:headers headers))) (request (build-request uri #:headers headers)))
(define response (define response
(dynamic-wind (dynamic-wind
@ -313,7 +316,7 @@ response from URI, and additional details, such as the actual HTTP response."
('ftp ('ftp
(catch #t (catch #t
(lambda () (lambda ()
(let ((conn (ftp-open (uri-host uri) 21))) (let ((conn (ftp-open (uri-host uri) 21 #:timeout timeout)))
(define response (define response
(dynamic-wind (dynamic-wind
(const #f) (const #f)
@ -338,7 +341,7 @@ response from URI, and additional details, such as the actual HTTP response."
"Return #t if the given URI can be reached, otherwise return #f and 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 #:timeout 3))) ;wait at most 3 seconds
(case status (case status
((http-response) ((http-response)
(or (= 200 (response-code argument)) (or (= 200 (response-code argument))