[bug#70494] [PATCH 21/23] scripts: substitute: Don't enforce cached connections in download-nar.

[Christopher Baines]

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 | 84 +++++++++++++++----------------------
 1 file changed, 33 insertions(+), 51 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index b4bb9d51ff..38975ec366 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -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
-- 
2.41.0