05/05: lint: Have connections time out after 3 seconds.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit bd7e1ffae6c91680e3328974f94c3ead8d2f378d
Author: Ludovic Courtès <address@hidden>
Date:   Thu Nov 12 23:17:12 2015 +0100

    lint: Have connections time out after 3 seconds.
    
    * 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'.
---
 guix/scripts/lint.scm |   13 ++++++++-----
 1 files changed, 8 insertions(+), 5 deletions(-)

diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index b1707ad..a7618ee 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -266,10 +266,13 @@ the synopsis")
      (check-start-with-package-name 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
 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
     '((User-Agent . "GNU Guile")
       (Accept . "*/*")))
@@ -280,7 +283,7 @@ response from URI, and additional details, such as the 
actual HTTP response."
       ((or 'http 'https)
        (catch #t
          (lambda ()
-           (let ((port    (open-connection-for-uri uri))
+           (let ((port    (open-connection-for-uri uri #:timeout timeout))
                  (request (build-request uri #:headers headers)))
              (define response
                (dynamic-wind
@@ -313,7 +316,7 @@ response from URI, and additional details, such as the 
actual HTTP response."
       ('ftp
        (catch #t
          (lambda ()
-           (let ((conn (ftp-open (uri-host uri) 21)))
+           (let ((conn (ftp-open (uri-host uri) 21 #:timeout timeout)))
              (define response
                (dynamic-wind
                  (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
 warning for PACKAGE mentionning the FIELD."
   (let-values (((status argument)
-                (probe-uri uri)))
+                (probe-uri uri #:timeout 3)))     ;wait at most 3 seconds
     (case status
       ((http-response)
        (or (= 200 (response-code argument))