ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-15 11:25:22 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

download: Default to a 10s connection establishment timeout.

Browse source 
* 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'.
This commit is contained in:
Ludovic Courtès 2016-05-27 10:33:23 +02:00
parent dab2472c6a
commit b18ede2704
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 13 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
guix/build/download.scm
View file

@ -234,9 +234,10 @@ (define (nar-uri-abbreviation uri)
(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 @@ (define (remove-dot-segments path)
#: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 @@ (define headers
(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 @@ (define headers
(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 @@ (define (maybe-expand-mirrors uri mirrors)
(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 @@ (define (fetch uri file)
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)