futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

substitute: Keep the initial connection alive.

Browse Source 
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:
Ludovic Courtès 2016-03-14 22:44:59 +01:00
parent d262a0f36b
commit 026ca50fa4
1 changed files with 63 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
guix/scripts/substitute.scm
View File

@ -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))
"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")))
(and=> (download (string-append url "/nix-cache-info"))
(lambda (properties)
(alist->record properties
(cut %make-cache-info url <...>)
'("StoreDir" "WantMassQuery")))))
(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