@@ -100,15 +100,17 @@ (define* (http-fetch uri #:key port (text? #f) (buffered? #t)
Write information about redirects to LOG-PORT.
Raise an '&http-get-error' condition if downloading fails."
- (define uri*
+ (define parsed-initial-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)
+ (define (open-connection* uri)
+ (open-connection uri
+ #:verify-certificate? verify-certificate?
+ #:timeout timeout))
+
+ (let loop ((current-uri parsed-initial-uri)
+ (current-port (or port (open-connection parsed-initial-uri))))
+ (let ((headers (match (uri-userinfo current-uri)
((? string? str)
(cons (cons 'Authorization
(string-append "Basic "
@@ -116,10 +118,10 @@ (define uri*
(string->utf8 str))))
headers))
(_ headers))))
- (unless (or buffered? (not (file-port? port)))
- (setvbuf port 'none))
+ (unless (or buffered? (not (file-port? current-port)))
+ (setvbuf current-port 'none))
(let*-values (((resp data)
- (http-get uri #:streaming? #t #:port port
+ (http-get current-uri #:streaming? #t #:port current-port
#:keep-alive? keep-alive?
#:headers headers))
((code)
@@ -132,36 +134,34 @@ (define uri*
303 ; see other
307 ; temporary redirection
308) ; permanent redirection
- (let ((host (uri-host uri))
- (uri (resolve-uri-reference (response-location resp) uri)))
+ (let ((host (uri-host current-uri))
+ (new-uri (resolve-uri-reference (response-location resp)
+ current-uri)))
(if keep-alive?
(dump-port data (%make-void-port "w0")
(response-content-length resp))
- (close-port port))
+ (close-port current-port))
(format log-port (G_ "following redirection to `~a'...~%")
- (uri->string uri))
- (loop uri
+ (uri->string new-uri))
+ (loop new-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)))))
+ (or (not (uri-host new-uri))
+ (string=? host (uri-host new-uri)))
+ current-port)
+ (open-connection* new-uri)))))
(else
(raise (condition (&http-get-error
- (uri uri)
- (code code)
- (reason (response-reason-phrase resp))
- (headers (response-headers resp)))
- (&message
- (message
- (format
- #f
- (G_ "~a: HTTP download failed: ~a (~s)")
- (uri->string uri) code
- (response-reason-phrase resp))))))))))))
+ (uri current-uri)
+ (code code)
+ (reason (response-reason-phrase resp))
+ (headers (response-headers resp)))
+ (&message
+ (message
+ (format
+ #f
+ (G_ "~a: HTTP download failed: ~a (~s)")
+ (uri->string current-uri) code
+ (response-reason-phrase resp))))))))))))
(define-syntax-rule (false-if-networking-error exp)
"Return #f if EXP triggers a network related exception as can occur when