diff options
| -rw-r--r-- | guix/build/download.scm | 22 |
1 files 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) |