summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/http-client.scm35
1 files changed, 24 insertions, 11 deletions
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 4b01e31165..143ed6de31 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -100,14 +100,15 @@ TIMEOUT is #f, connection establishment never times out.
Write information about redirects to LOG-PORT.
Raise an '&http-get-error' condition if downloading fails."
- (let loop ((uri (if (string? uri)
- (string->uri uri)
- uri)))
- (let ((port (or port (open-connection uri
- #:verify-certificate?
- verify-certificate?
- #:timeout timeout)))
- (headers (match (uri-userinfo uri)
+ (define uri*
+ (if (string? uri) (string->uri uri) uri))
+
+ (let loop ((uri uri*)
+ (port (or port (open-connection uri*
+ #:verify-certificate?
+ verify-certificate?
+ #:timeout timeout))))
+ (let ((headers (match (uri-userinfo uri)
((? string? str)
(cons (cons 'Authorization
(string-append "Basic "
@@ -131,11 +132,23 @@ Raise an '&http-get-error' condition if downloading fails."
303 ; see other
307 ; temporary redirection
308) ; permanent redirection
- (let ((uri (resolve-uri-reference (response-location resp) uri)))
- (close-port port)
+ (let ((host (uri-host uri))
+ (uri (resolve-uri-reference (response-location resp) uri)))
+ (if keep-alive?
+ (dump-port data (%make-void-port "w0")
+ (response-content-length resp))
+ (close-port port))
(format log-port (G_ "following redirection to `~a'...~%")
(uri->string uri))
- (loop uri)))
+ (loop uri
+ (or (and keep-alive?
+ (or (not (uri-host uri))
+ (string=? host (uri-host uri)))
+ port)
+ (open-connection uri*
+ #:verify-certificate?
+ verify-certificate?
+ #:timeout timeout)))))
(else
(raise (condition (&http-get-error
(uri uri)