05/06: substitute: Keep the initial connection alive.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 026ca50fa4c46a8e280cd51621bbec76b12c0757
Author: Ludovic Courtès <address@hidden>
Date:   Mon Mar 14 22:44:59 2016 +0100

    substitute: Keep the initial connection alive.
    
    The connection used to fetch /nix-cache-info is now reused for the
    subsequent narinfo requests.
    
    * guix/scripts/substitute.scm (download-cache-info)[download]: Remove.
    [uri, read-cache-info]: New variables.
    Rewrite in terms of 'http-fetch' instead of 'fetch'.  Return an open
    port in addition to a <cache-info>.
    * guix/scripts/substitute.scm (http-multiple-get): Add #:port parameter
    and honor it.
    (fetch-narinfos)[do-fetch]: Add 'port' parameter.
    Adjust to new 'download-cache-info' and 'do-fetch' signatures.
---
 guix/scripts/substitute.scm |   95 +++++++++++++++++++++++++++++--------------
 1 files changed, 64 insertions(+), 31 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index d20c82a..524d453 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -216,19 +216,46 @@ provide."
   (wants-mass-query? cache-info-wants-mass-query?))
 
 (define (download-cache-info url)
-  "Download the information for the cache at URL.  Return a <cache-info>
-object on success, or #f on failure."
-  (define (download url)
-    ;; Download the `nix-cache-info' from URL, and return its contents as an
-    ;; list of key/value pairs.
-    (and=> (false-if-exception (fetch (string->uri url)))
-           fields->alist))
-
-  (and=> (download (string-append url "/nix-cache-info"))
-         (lambda (properties)
-           (alist->record properties
-                          (cut %make-cache-info url <...>)
-                          '("StoreDir" "WantMassQuery")))))
+  "Download the information for the cache at URL.  On success, return a
+<cache-info> object and a port on which to send further HTTP requests.  On
+failure, return #f and #f."
+  (define uri
+    (string->uri (string-append url "/nix-cache-info")))
+
+  (define (read-cache-info port)
+    (alist->record (fields->alist port)
+                   (cut %make-cache-info url <...>)
+                   '("StoreDir" "WantMassQuery")))
+
+  (catch #t
+    (lambda ()
+      (case (uri-scheme uri)
+        ((file)
+         (values (call-with-input-file (uri-path uri)
+                   read-cache-info)
+                 #f))
+        ((http https)
+         (let ((port (open-connection-for-uri uri
+                                              #:timeout %fetch-timeout)))
+           (guard (c ((http-get-error? c)
+                      (warning (_ "while fetching '~a': ~a (~s)~%")
+                               (uri->string (http-get-error-uri c))
+                               (http-get-error-code c)
+                               (http-get-error-reason c))
+                      (close-port port)
+                      (warning (_ "ignoring substitute server at '~s'~%") url)
+                      (values #f #f)))
+             (values (read-cache-info (http-fetch uri
+                                                  #:port port
+                                                  #:keep-alive? #t))
+                     port))))))
+    (lambda (key . args)
+      (case key
+        ((getaddrinfo-error system-error)
+         ;; Silently ignore the error: probably due to lack of network access.
+         (values #f #f))
+        (else
+         (apply throw key args))))))
 
 
 (define-record-type <narinfo>
@@ -477,16 +504,19 @@ may be #f, in which case it indicates that PATH is 
unavailable at CACHE-URL."
                             ".narinfo")))
     (build-request (string->uri url) #:method 'GET)))
 
-(define (http-multiple-get base-uri proc seed requests)
+(define* (http-multiple-get base-uri proc seed requests
+                            #:key port)
   "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."
-  (let connect ((requests requests)
+'fold'.  Return the final result.  When PORT is specified, use it as the
+initial connection on which HTTP requests are sent."
+  (let connect ((port     port)
+                (requests requests)
                 (result   seed))
     ;; (format (current-error-port) "connecting (~a requests left)..."
     ;;         (length requests))
-    (let ((p (open-connection-for-uri base-uri)))
+    (let ((p (or port (open-connection-for-uri base-uri))))
       ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
       (when (file-port? p)
         (setvbuf p _IOFBF (expt 2 16)))
@@ -520,7 +550,7 @@ read the response body, and the previous result, starting 
with SEED, Ã  la
              (match (assq 'connection (response-headers resp))
                (('connection 'close)
                 (close-port p)
-                (connect tail result))            ;try again
+                (connect #f tail result))         ;try again
                (_
                 (loop tail result))))))))))       ;keep going
 
@@ -579,14 +609,17 @@ if file doesn't exist, and the narinfo otherwise."
              (read-to-eof port))
          result))))
 
-  (define (do-fetch uri)
+  (define (do-fetch uri port)
     (case (and=> uri uri-scheme)
       ((http https)
        (let ((requests (map (cut narinfo-request url <>) paths)))
          (update-progress!)
          (let ((result (http-multiple-get uri
                                           handle-narinfo-response '()
-                                          requests)))
+                                          requests
+                                          #:port port)))
+           (unless (port-closed? port)
+             (close-port port))
            (newline (current-error-port))
            result)))
       ((file #f)
@@ -599,17 +632,17 @@ if file doesn't exist, and the narinfo otherwise."
        (leave (_ "~s: unsupported server URI scheme~%")
               (if uri (uri-scheme uri) url)))))
 
-  (define cache-info
-    (download-cache-info url))
-
-  (and cache-info
-       (if (string=? (cache-info-store-directory cache-info)
-                     (%store-prefix))
-           (do-fetch (string->uri url))
-           (begin
-             (warning (_ "'~a' uses different store '~a'; ignoring it~%")
-                      url (cache-info-store-directory cache-info))
-             #f))))
+  (let-values (((cache-info port)
+                (download-cache-info url)))
+    (and cache-info
+         (if (string=? (cache-info-store-directory cache-info)
+                       (%store-prefix))
+             (do-fetch (string->uri url) port)    ;reuse PORT
+             (begin
+               (warning (_ "'~a' uses different store '~a'; ignoring it~%")
+                        url (cache-info-store-directory cache-info))
+               (close-port port)
+               #f)))))
 
 (define (lookup-narinfos cache paths)
   "Return the narinfos for PATHS, invoking the server at CACHE when no