From b18ede2704ca1b1bdfa5a0d5655bee90ef05fa0f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 27 May 2016 10:33:23 +0200
Subject: [PATCH] download: Default to a 10s connection establishment timeout.

* guix/build/download.scm (ftp-fetch): Add #:timeout and pass it to
'ftp-open'.
(http-fetch): Add #:timeout and pass it to 'open-connection-for-uri' and
in recursive calls.
(url-fetch): Add #:timeout and pass it to 'http-fetch' and 'ftp-fetch'.
---
 guix/build/download.scm | 22 +++++++++++++---------
 1 file changed, 13 insertions(+), 9 deletions(-)

diff --git a/guix/build/download.scm b/guix/build/download.scm
index ef515efdbf..bd011ce878 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -234,9 +234,10 @@ and 'guix publish', something like
         (string-drop path 33)
         path)))
 
-(define (ftp-fetch uri file)
-  "Fetch data from URI and write it to FILE.  Return FILE on success."
-  (let* ((conn (ftp-open (uri-host uri)))
+(define* (ftp-fetch uri file #:key timeout)
+  "Fetch data from URI and write it to FILE.  Return FILE on success.  Bail
+out if the connection could not be established in less than TIMEOUT seconds."
+  (let* ((conn (ftp-open (uri-host uri) #:timeout timeout))
          (size (false-if-exception (ftp-size conn (uri-path uri))))
          (in   (ftp-retr conn (basename (uri-path uri))
                          (dirname (uri-path uri)))))
@@ -585,8 +586,10 @@ Return the resulting target URI."
                     #:query    (uri-query    ref)
                     #:fragment (uri-fragment ref)))))
 
-(define (http-fetch uri file)
-  "Fetch data from URI and write it to FILE.  Return FILE on success."
+(define* (http-fetch uri file #:key timeout)
+  "Fetch data from URI and write it to FILE; when TIMEOUT is true, bail out if
+the connection could not be established in less than TIMEOUT seconds.  Return
+FILE on success."
 
   (define post-2.0.7?
     (or (> (string->number (major-version)) 2)
@@ -605,7 +608,7 @@ Return the resulting target URI."
       (Accept . "*/*")))
 
   (let*-values (((connection)
-                 (open-connection-for-uri uri))
+                 (open-connection-for-uri uri #:timeout timeout))
                 ((resp bv-or-port)
                  ;; XXX: `http-get*' was introduced in 2.0.7, and replaced by
                  ;; #:streaming? in 2.0.8.  We know we're using it within the
@@ -646,7 +649,7 @@ Return the resulting target URI."
          (format #t "following redirection to `~a'...~%"
                  (uri->string uri))
          (close connection)
-         (http-fetch uri file)))
+         (http-fetch uri file #:timeout timeout)))
       (else
        (error "download failed" (uri->string uri)
               code (response-reason-phrase resp))))))
@@ -686,6 +689,7 @@ Return a list of URIs."
 
 (define* (url-fetch url file
                     #:key
+                    (timeout 10)
                     (mirrors '()) (content-addressed-mirrors '())
                     (hashes '()))
   "Fetch FILE from URL; URL may be either a single string, or a list of
@@ -711,9 +715,9 @@ or #f."
             file (uri->string uri))
     (case (uri-scheme uri)
       ((http https)
-       (false-if-exception* (http-fetch uri file)))
+       (false-if-exception* (http-fetch uri file #:timeout timeout)))
       ((ftp)
-       (false-if-exception* (ftp-fetch uri file)))
+       (false-if-exception* (ftp-fetch uri file #:timeout timeout)))
       (else
        (format #t "skipping URI with unsupported scheme: ~s~%"
                uri)