@@ -410,55 +410,25 @@ (define open-connection-for-uri/cached
(drain-input socket)
socket))))))))
-(define kind-and-args-exception?
- (exception-predicate &exception-with-kind-and-args))
-
-(define (call-with-cached-connection uri proc)
- (let ((port (open-connection-for-uri/cached uri
- #:verify-certificate? #f)))
- (guard (c ((kind-and-args-exception? c)
- (let ((key (exception-kind c))
- (args (exception-args c)))
- ;; If PORT was cached and the server closed the connection in the
- ;; meantime, we get EPIPE. In that case, open a fresh connection
- ;; and retry. We might also get 'bad-response or a similar
- ;; exception from (web response) later on, once we've sent the
- ;; request, or a ERROR/INVALID-SESSION from GnuTLS.
- (if (or (and (eq? key 'system-error)
- (= EPIPE (system-error-errno `(,key ,@args))))
- (and (eq? key 'gnutls-error)
- (memq (first args)
- (list error/invalid-session
-
- ;; XXX: These two are not properly handled in
- ;; GnuTLS < 3.7.3, in
- ;; 'write_to_session_record_port'; see
- ;; <https://bugs.gnu.org/47867>.
- error/again error/interrupted)))
- (memq key '(bad-response bad-header bad-header-component)))
- (proc (open-connection-for-uri/cached uri
- #:verify-certificate? #f
- #:fresh? #t))
- (raise c))))
- (#t
- ;; An exception that's not handled here, such as
- ;; '&http-get-error'. Re-raise it.
- (raise c)))
- (proc port))))
-
-(define-syntax-rule (with-cached-connection uri port exp ...)
- "Bind PORT with EXP... to a socket connected to URI."
- (call-with-cached-connection uri (lambda (port) exp ...)))
-
(define-syntax-rule (catch-system-error exp)
(catch 'system-error
(lambda () exp)
(const #f)))
+(define http-response-error?
+ (let ((kind-and-args-exception?
+ (exception-predicate &exception-with-kind-and-args)))
+ (lambda (exception)
+ "Return true if EXCEPTION denotes an error with the http response"
+ (->bool
+ (memq (exception-kind exception)
+ '(bad-response bad-header bad-header-component))))))
+
(define* (download-nar narinfo destination
#:key deduplicate? print-build-trace?
(fetch-timeout %fetch-timeout)
- prefer-fast-decompression?)
+ prefer-fast-decompression?
+ (open-connection-for-uri guix:open-connection-for-uri))
"Download the nar prescribed in NARINFO, which is assumed to be authentic
and authorized, and write it to DESTINATION. When DEDUPLICATE? is true, and
if DESTINATION is in the store, deduplicate its files."
@@ -487,11 +457,22 @@ (define* (download-nar narinfo destination
(warning (G_ "while fetching ~a: server is somewhat slow~%")
(uri->string uri))
(warning (G_ "try `--no-substitutes' if the problem persists~%")))
- (with-cached-connection uri port
- (http-fetch uri #:text? #f
- #:port port
- #:keep-alive? #t
- #:buffered? #f))))
+ (let loop ((port (open-connection-for-uri uri))
+ (attempt 0))
+ (guard (c ((or (network-error? c)
+ (http-response-error? c))
+ (close-port port)
+
+ ;; Perform a single retry in the case of an error,
+ ;; mostly to mimic the behaviour of
+ ;; with-cached-connection
+ (if (= attempt 0)
+ (loop (open-connection-for-uri uri) 1)
+ (raise c))))
+ (http-fetch uri #:text? #f
+ #:port port
+ #:keep-alive? #t
+ #:buffered? #f)))))
(else
(raise
(formatted-message
@@ -612,7 +593,9 @@ (define* (process-substitution/fallback narinfo destination
#:deduplicate? deduplicate?
#:print-build-trace? print-build-trace?
#:prefer-fast-decompression?
- prefer-fast-decompression?))
+ prefer-fast-decompression?
+ #:open-connection-for-uri
+ open-connection-for-uri/cached))
(loop rest)))
(()
(loop rest)))))))
@@ -663,7 +646,9 @@ (define* (process-substitution store-item destination
(download-nar narinfo destination
#:deduplicate? deduplicate?
#:print-build-trace? print-build-trace?
- #:prefer-fast-decompression? prefer-fast-decompression?))))
+ #:prefer-fast-decompression? prefer-fast-decompression?
+ #:open-connection-for-uri
+ open-connection-for-uri/cached))))
(values narinfo
expected-hash
actual-hash)))
@@ -930,10 +915,7 @@ (define-command (guix-substitute . args)
(leave (G_ "~a: unrecognized options~%") opts))))))
;;; Local Variables:
-;;; eval: (put 'with-timeout 'scheme-indent-function 1)
;;; eval: (put 'with-redirected-error-port 'scheme-indent-function 0)
-;;; eval: (put 'with-cached-connection 'scheme-indent-function 2)
-;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1)
;;; End:
;;; substitute.scm ends here