guix_mirror_bot pushed a commit to branch master
in repository guix.
commit 41a20ca0d21f592c29fbb72d1d9d5e769f8432a4
Author: Christopher Baines <[email protected]>
AuthorDate: Tue Apr 9 12:13:26 2024 +0100
scripts: substitute: Don't enforce cached connections in download-nar.
This is in preparation for moving the download-nar procedure out of the
script.
As well as calling open-connection-for-uri/cached, with-cached-connection
adds
a single retry to the expression passed in, in the case of a exception that
suggests there's a problem with the cached connection. This is important
because download-nar/http-fetch doesn't check if a connection used for
multiple requests should be closed (because the servers set the relevant
response header).
To make download-nar more generic, have it take open-connection-for-uri as a
keyword argument, and replicate the with-cached-connection single retry by
closing the port in the case of a network error, and recalling
open-connection-for-uri. This will work fine in the case when connection
caching is not in use, as well as when open-connection-for-uri/cached is
used,
since open-connection-for-uri/cached will open a new connection if the
cached
port is closed.
* guix/scripts/substitute.scm (kind-and-args-exception?): Remove and inline
where necessary.
(call-with-cached-connection): Remove procedure.
(with-cached-connection): Remove syntax rule.
(http-response-error?): New procedure.
(download-nar): Add new #:open-connection-for-uri keyword argument and use
it,
also replace with-cached-connection.
(process-substitution/fallback,process-substitution): Pass
#:open-connection-for-uri open-connection-for-uri/cached to download-nar.
Change-Id: I277b1d8dfef79aa1711755b10b9944da7c19157c
---
guix/scripts/substitute.scm | 99 ++++++++++++++++++---------------------------
1 file changed, 39 insertions(+), 60 deletions(-)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 89038103bb..936813a7d5 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -411,63 +411,29 @@ server certificates."
(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
-
- ;; "Error in the push function" is
- ;; usually a transient error.
- error/push-error
- error/pull-error
-
- ;; 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)
- fast-decompression?)
+ 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."
+if DESTINATION is in the store, deduplicate its files. Use
+OPEN-CONNECTION-FOR-URI to open connections."
(define destination-in-store?
(string-prefix? (string-append (%store-prefix) "/")
destination))
@@ -493,15 +459,26 @@ if DESTINATION is in the store, deduplicate its files."
(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
- (let ((raw
- response
- (http-fetch uri #:text? #f
- #:port port
- #:keep-alive? #t
- #:buffered? #f)))
- (values raw
- (response-content-length response))))))
+ (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))))
+ (let ((port
+ response
+ (http-fetch uri #:text? #f
+ #:port port
+ #:keep-alive? #t
+ #:buffered? #f)))
+ (values port
+ (response-content-length response)))))))
(else
(raise
(formatted-message
@@ -622,7 +599,9 @@ way to download the nar."
#:deduplicate? deduplicate?
#:print-build-trace? print-build-trace?
#:fast-decompression?
- fast-decompression?))
+ fast-decompression?
+ #:open-connection-for-uri
+ open-connection-for-uri/cached))
(loop rest)))
(()
(loop rest)))))))
@@ -673,7 +652,9 @@ PORT."
(download-nar narinfo destination
#:deduplicate? deduplicate?
#:print-build-trace? print-build-trace?
- #:fast-decompression? fast-decompression?))))
+ #:fast-decompression? fast-decompression?
+ #:open-connection-for-uri
+ open-connection-for-uri/cached))))
(values narinfo
expected-hash
actual-hash)))
@@ -943,8 +924,6 @@ default value."
;;; 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
