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.
This commit is contained in:
parent
d262a0f36b
commit
026ca50fa4
|
@ -216,19 +216,46 @@ provide."
|
||||||
(wants-mass-query? cache-info-wants-mass-query?))
|
(wants-mass-query? cache-info-wants-mass-query?))
|
||||||
|
|
||||||
(define (download-cache-info url)
|
(define (download-cache-info url)
|
||||||
"Download the information for the cache at URL. Return a <cache-info>
|
"Download the information for the cache at URL. On success, return a
|
||||||
object on success, or #f on failure."
|
<cache-info> object and a port on which to send further HTTP requests. On
|
||||||
(define (download url)
|
failure, return #f and #f."
|
||||||
;; Download the `nix-cache-info' from URL, and return its contents as an
|
(define uri
|
||||||
;; list of key/value pairs.
|
(string->uri (string-append url "/nix-cache-info")))
|
||||||
(and=> (false-if-exception (fetch (string->uri url)))
|
|
||||||
fields->alist))
|
|
||||||
|
|
||||||
(and=> (download (string-append url "/nix-cache-info"))
|
(define (read-cache-info port)
|
||||||
(lambda (properties)
|
(alist->record (fields->alist port)
|
||||||
(alist->record properties
|
|
||||||
(cut %make-cache-info url <...>)
|
(cut %make-cache-info url <...>)
|
||||||
'("StoreDir" "WantMassQuery")))))
|
'("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>
|
(define-record-type <narinfo>
|
||||||
|
@ -477,16 +504,19 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL."
|
||||||
".narinfo")))
|
".narinfo")))
|
||||||
(build-request (string->uri url) #:method 'GET)))
|
(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
|
"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
|
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
|
read the response body, and the previous result, starting with SEED, à la
|
||||||
'fold'. Return the final result."
|
'fold'. Return the final result. When PORT is specified, use it as the
|
||||||
(let connect ((requests requests)
|
initial connection on which HTTP requests are sent."
|
||||||
|
(let connect ((port port)
|
||||||
|
(requests requests)
|
||||||
(result seed))
|
(result seed))
|
||||||
;; (format (current-error-port) "connecting (~a requests left)..."
|
;; (format (current-error-port) "connecting (~a requests left)..."
|
||||||
;; (length requests))
|
;; (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'.
|
;; For HTTPS, P is not a file port and does not support 'setvbuf'.
|
||||||
(when (file-port? p)
|
(when (file-port? p)
|
||||||
(setvbuf p _IOFBF (expt 2 16)))
|
(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))
|
(match (assq 'connection (response-headers resp))
|
||||||
(('connection 'close)
|
(('connection 'close)
|
||||||
(close-port p)
|
(close-port p)
|
||||||
(connect tail result)) ;try again
|
(connect #f tail result)) ;try again
|
||||||
(_
|
(_
|
||||||
(loop tail result)))))))))) ;keep going
|
(loop tail result)))))))))) ;keep going
|
||||||
|
|
||||||
|
@ -579,14 +609,17 @@ if file doesn't exist, and the narinfo otherwise."
|
||||||
(read-to-eof port))
|
(read-to-eof port))
|
||||||
result))))
|
result))))
|
||||||
|
|
||||||
(define (do-fetch uri)
|
(define (do-fetch uri port)
|
||||||
(case (and=> uri uri-scheme)
|
(case (and=> uri uri-scheme)
|
||||||
((http https)
|
((http https)
|
||||||
(let ((requests (map (cut narinfo-request url <>) paths)))
|
(let ((requests (map (cut narinfo-request url <>) paths)))
|
||||||
(update-progress!)
|
(update-progress!)
|
||||||
(let ((result (http-multiple-get uri
|
(let ((result (http-multiple-get uri
|
||||||
handle-narinfo-response '()
|
handle-narinfo-response '()
|
||||||
requests)))
|
requests
|
||||||
|
#:port port)))
|
||||||
|
(unless (port-closed? port)
|
||||||
|
(close-port port))
|
||||||
(newline (current-error-port))
|
(newline (current-error-port))
|
||||||
result)))
|
result)))
|
||||||
((file #f)
|
((file #f)
|
||||||
|
@ -599,17 +632,17 @@ if file doesn't exist, and the narinfo otherwise."
|
||||||
(leave (_ "~s: unsupported server URI scheme~%")
|
(leave (_ "~s: unsupported server URI scheme~%")
|
||||||
(if uri (uri-scheme uri) url)))))
|
(if uri (uri-scheme uri) url)))))
|
||||||
|
|
||||||
(define cache-info
|
(let-values (((cache-info port)
|
||||||
(download-cache-info url))
|
(download-cache-info url)))
|
||||||
|
|
||||||
(and cache-info
|
(and cache-info
|
||||||
(if (string=? (cache-info-store-directory cache-info)
|
(if (string=? (cache-info-store-directory cache-info)
|
||||||
(%store-prefix))
|
(%store-prefix))
|
||||||
(do-fetch (string->uri url))
|
(do-fetch (string->uri url) port) ;reuse PORT
|
||||||
(begin
|
(begin
|
||||||
(warning (_ "'~a' uses different store '~a'; ignoring it~%")
|
(warning (_ "'~a' uses different store '~a'; ignoring it~%")
|
||||||
url (cache-info-store-directory cache-info))
|
url (cache-info-store-directory cache-info))
|
||||||
#f))))
|
(close-port port)
|
||||||
|
#f)))))
|
||||||
|
|
||||||
(define (lookup-narinfos cache paths)
|
(define (lookup-narinfos cache paths)
|
||||||
"Return the narinfos for PATHS, invoking the server at CACHE when no
|
"Return the narinfos for PATHS, invoking the server at CACHE when no
|
||||||
|
|
Loading…
Reference in New Issue