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

1 files 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 @@ 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
-
-                                          ;; 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 @@ 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
-           (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 @@ way to download the nar."
                               #: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 @@ PORT."
            (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 @@ default value."
         (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