[bug#45323] [PATCH] substitute: Reuse connections for '--query'.

[Ludovic Courtès]

This significantly speeds up things like substituting the closure of a
.drv.  This is a followup to 5ff521452b9ec2aae9ed8e4bb7bdc250a581f203.

* guix/scripts/substitute.scm (http-multiple-get): Add #:open-connection
and #:keep-alive? and honor them.
(open-connection-for-uri/maybe): Use 'open-connection-for-uri/cached'
instead of 'guix:open-connection-for-uri'.  Call 'http-multiple-get'
within 'call-with-cached-connection'.
(open-connection-for-uri/cached): Add #:timeout and #:verify-certificate?
and honor them.
(call-with-cached-connection): Add 'open-connection'  parameter and
honor it.
---
 guix/scripts/substitute.scm | 97 ++++++++++++++++++++++---------------
 1 file changed, 59 insertions(+), 38 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 38702d0c4b..8084c89ae5 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -514,12 +514,18 @@ return its MAX-LENGTH first elements and its tail."
 
 (define* (http-multiple-get base-uri proc seed requests
                             #:key port (verify-certificate? #t)
+                            (open-connection guix:open-connection-for-uri)
+                            (keep-alive? #t)
                             (batch-size 1000))
   "Send all of REQUESTS to the server at BASE-URI.  Call PROC for each
 response, passing it the request object, the response, a port from which to
 read the response body, and the previous result, starting with SEED, à la
-'fold'.  Return the final result.  When PORT is specified, use it as the
-initial connection on which HTTP requests are sent."
+'fold'.  Return the final result.
+
+When PORT is specified, use it as the initial connection on which HTTP
+requests are sent; otherwise call OPEN-CONNECTION to open a new connection for
+a URI.  When KEEP-ALIVE? is false, close the connection port before
+returning."
   (let connect ((port     port)
                 (requests requests)
                 (result   seed))
@@ -528,10 +534,9 @@ initial connection on which HTTP requests are sent."
 
     ;; (format (current-error-port) "connecting (~a requests left)..."
     ;;         (length requests))
-    (let ((p (or port (guix:open-connection-for-uri
-                       base-uri
-                       #:verify-certificate?
-                       verify-certificate?))))
+    (let ((p (or port (open-connection base-uri
+                                       #:verify-certificate?
+                                       verify-certificate?))))
       ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
       (when (file-port? p)
         (setvbuf p 'block (expt 2 16)))
@@ -556,7 +561,8 @@ initial connection on which HTTP requests are sent."
           (()
            (match (drop requests processed)
              (()
-              (close-port p)
+              (unless keep-alive?
+                (close-port p))
               (reverse result))
              (remainder
               (connect p remainder result))))
@@ -598,18 +604,18 @@ if file doesn't exist, and the narinfo otherwise."
 
 (define* (open-connection-for-uri/maybe uri
                                         #:key
-                                        (verify-certificate? #f)
+                                        fresh?
                                         (time %fetch-timeout))
-  "Open a connection to URI and return a port to it, or, if connection failed,
-print a warning and return #f."
+  "Open a connection to URI via 'open-connection-for-uri/cached' and return a
+port to it, or, if connection failed, print a warning and return #f.  Pass
+#:fresh? to 'open-connection-for-uri/cached'."
   (define host
     (uri-host uri))
 
   (catch #t
     (lambda ()
-      (guix:open-connection-for-uri uri
-                                    #:verify-certificate? verify-certificate?
-                                    #:timeout time))
+      (open-connection-for-uri/cached uri #:timeout time
+                                      #:fresh? fresh?))
     (match-lambda*
       (('getaddrinfo-error error)
        (unless (hash-ref %unreachable-hosts host)
@@ -683,23 +689,26 @@ print a warning and return #f."
   (define (do-fetch uri)
     (case (and=> uri uri-scheme)
       ((http https)
-       (let ((requests (map (cut narinfo-request url <>) paths)))
-         (match (open-connection-for-uri/maybe uri)
-           (#f
-            '())
-           (port
-            (update-progress!)
-            ;; Note: Do not check HTTPS server certificates to avoid depending
-            ;; on the X.509 PKI.  We can do it because we authenticate
-            ;; narinfos, which provides a much stronger guarantee.
-            (let ((result (http-multiple-get uri
-                                             handle-narinfo-response '()
-                                             requests
-                                             #:verify-certificate? #f
-                                             #:port port)))
-              (close-port port)
-              (newline (current-error-port))
-              result)))))
+       ;; Note: Do not check HTTPS server certificates to avoid depending
+       ;; on the X.509 PKI.  We can do it because we authenticate
+       ;; narinfos, which provides a much stronger guarantee.
+       (let* ((requests (map (cut narinfo-request url <>) paths))
+              (result   (call-with-cached-connection uri
+                          (lambda (port)
+                            (if port
+                                (begin
+                                  (update-progress!)
+                                  (http-multiple-get uri
+                                                     handle-narinfo-response 
'()
+                                                     requests
+                                                     #:open-connection
+                                                     
open-connection-for-uri/cached
+                                                     #:verify-certificate? #f
+                                                     #:port port))
+                                '()))
+                          open-connection-for-uri/maybe)))
+         (newline (current-error-port))
+         result))
       ((file #f)
        (let* ((base  (string-append (uri-path uri) "/"))
               (files (map (compose (cut string-append base <> ".narinfo")
@@ -990,10 +999,14 @@ the URI, its compression method (a string), and the 
compressed file size."
 
 (define open-connection-for-uri/cached
   (let ((cache '()))
-    (lambda* (uri #:key fresh?)
+    (lambda* (uri #:key fresh? timeout verify-certificate?)
       "Return a connection for URI, possibly reusing a cached connection.
-When FRESH? is true, delete any cached connections for URI and open a new
-one.  Return #f if URI's scheme is 'file' or #f."
+When FRESH? is true, delete any cached connections for URI and open a new one.
+Return #f if URI's scheme is 'file' or #f.
+
+When true, TIMEOUT is the maximum number of milliseconds to wait for
+connection establishment.  When VERIFY-CERTIFICATE? is true, verify HTTPS
+server certificates."
       (define host (uri-host uri))
       (define scheme (uri-scheme uri))
       (define key (list host scheme (uri-port uri)))
@@ -1005,7 +1018,9 @@ one.  Return #f if URI's scheme is 'file' or #f."
               ;; CACHE, if any.
               (let-values (((socket)
                             (guix:open-connection-for-uri
-                             uri #:verify-certificate? #f))
+                             uri
+                             #:verify-certificate? verify-certificate?
+                             #:timeout timeout))
                            ((new-cache evicted)
                             (at-most (- %max-cached-connections 1) cache)))
                 (for-each (match-lambda
@@ -1019,14 +1034,19 @@ one.  Return #f if URI's scheme is 'file' or #f."
                   (begin
                     (false-if-exception (close-port socket))
                     (set! cache (alist-delete key cache))
-                    (open-connection-for-uri/cached uri))
+                    (open-connection-for-uri/cached uri #:timeout timeout
+                                                    #:verify-certificate?
+                                                    verify-certificate?))
                   (begin
                     ;; Drain input left from the previous use.
                     (drain-input socket)
                     socket))))))))
 
-(define (call-with-cached-connection uri proc)
-  (let ((port (open-connection-for-uri/cached uri)))
+(define* (call-with-cached-connection uri proc
+                                      #:optional
+                                      (open-connection
+                                       open-connection-for-uri/cached))
+  (let ((port (open-connection uri)))
     (catch #t
       (lambda ()
         (proc port))
@@ -1038,7 +1058,7 @@ one.  Return #f if URI's scheme is 'file' or #f."
         (if (or (and (eq? key 'system-error)
                      (= EPIPE (system-error-errno `(,key ,@args))))
                 (memq key '(bad-response bad-header bad-header-component)))
-            (proc (open-connection-for-uri/cached uri #:fresh? #t))
+            (proc (open-connection uri #:fresh? #t))
             (apply throw key args))))))
 
 (define-syntax-rule (with-cached-connection uri port exp ...)
@@ -1341,6 +1361,7 @@ default value."
 ;;; Local Variables:
 ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
 ;;; 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.29.2