ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-28 23:32:24 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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 @@ (define (check-start-with-package-name 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 @@ (define headers
((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 @@ (define 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 @@ (define (validate-uri uri package field)
"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))