summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-03-14 22:44:59 +0100
committerLudovic Courtès <ludo@gnu.org>2016-03-14 23:34:33 +0100
commit026ca50fa4c46a8e280cd51621bbec76b12c0757 (patch)
tree5cbbdac89dcf36482ee7f80e517adbffcc83a18e /guix/scripts
parentd262a0f36baa5276076fcd160da7cf7661876eca (diff)
downloadgnu-guix-026ca50fa4c46a8e280cd51621bbec76b12c0757.tar
gnu-guix-026ca50fa4c46a8e280cd51621bbec76b12c0757.tar.gz
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.
Diffstat (limited to 'guix/scripts')
-rwxr-xr-xguix/scripts/substitute.scm95
1 files changed, 64 insertions, 31 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index d20c82a770..524d453ffa 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