ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 15:36:20 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

substitute: Reuse connections for '--query'.

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

* 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.
This commit is contained in:
Ludovic Courtès 2020-12-19 15:41:46 +01:00
parent 769a7e4b97
commit be5a75ebb5
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 59 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

97
guix/scripts/substitute.scm
View file

@ -514,12 +514,18 @@ (define (at-most max-length lst)
(define* (http-multiple-get base-uri proc seed requests (define* (http-multiple-get base-uri proc seed requests
#:key port (verify-certificate? #t) #:key port (verify-certificate? #t)
(open-connection guix:open-connection-for-uri)
(keep-alive? #t)
(batch-size 1000)) (batch-size 1000))
"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. When PORT is specified, use it as the 'fold'. Return the final result.
initial connection on which HTTP requests are sent."
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) (let connect ((port port)
(requests requests) (requests requests)
(result seed)) (result seed))
@ -528,10 +534,9 @@ (define batch
;; (format (current-error-port) "connecting (~a requests left)..." ;; (format (current-error-port) "connecting (~a requests left)..."
;; (length requests)) ;; (length requests))
(let ((p (or port (guix:open-connection-for-uri (let ((p (or port (open-connection base-uri
base-uri #:verify-certificate?
#:verify-certificate? verify-certificate?))))
verify-certificate?))))
;; 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 'block (expt 2 16))) (setvbuf p 'block (expt 2 16)))
@ -556,7 +561,8 @@ (define batch
(() (()
(match (drop requests processed) (match (drop requests processed)
(() (()
(close-port p) (unless keep-alive?
(close-port p))
(reverse result)) (reverse result))
(remainder (remainder
(connect p remainder result)))) (connect p remainder result))))
@ -598,18 +604,18 @@ (define %unreachable-hosts
(define* (open-connection-for-uri/maybe uri (define* (open-connection-for-uri/maybe uri
#:key #:key
(verify-certificate? #f) fresh?
(time %fetch-timeout)) (time %fetch-timeout))
"Open a connection to URI and return a port to it, or, if connection failed, "Open a connection to URI via 'open-connection-for-uri/cached' and return a
print a warning and return #f." port to it, or, if connection failed, print a warning and return #f. Pass
#:fresh? to 'open-connection-for-uri/cached'."
(define host (define host
(uri-host uri)) (uri-host uri))
(catch #t (catch #t
(lambda () (lambda ()
(guix:open-connection-for-uri uri (open-connection-for-uri/cached uri #:timeout time
#:verify-certificate? verify-certificate? #:fresh? fresh?))
#:timeout time))
(match-lambda* (match-lambda*
(('getaddrinfo-error error) (('getaddrinfo-error error)
(unless (hash-ref %unreachable-hosts host) (unless (hash-ref %unreachable-hosts host)
@ -683,23 +689,26 @@ (define (handle-narinfo-response request response port result)
(define (do-fetch uri) (define (do-fetch uri)
(case (and=> uri uri-scheme) (case (and=> uri uri-scheme)
((http https) ((http https)
(let ((requests (map (cut narinfo-request url <>) paths))) ;; Note: Do not check HTTPS server certificates to avoid depending
(match (open-connection-for-uri/maybe uri) ;; on the X.509 PKI. We can do it because we authenticate
(#f ;; narinfos, which provides a much stronger guarantee.
'()) (let* ((requests (map (cut narinfo-request url <>) paths))
(port (result (call-with-cached-connection uri
(update-progress!) (lambda (port)
;; Note: Do not check HTTPS server certificates to avoid depending (if port
;; on the X.509 PKI. We can do it because we authenticate (begin
;; narinfos, which provides a much stronger guarantee. (update-progress!)
(let ((result (http-multiple-get uri (http-multiple-get uri
handle-narinfo-response '() handle-narinfo-response '()
requests requests
#:verify-certificate? #f #:open-connection
#:port port))) open-connection-for-uri/cached
(close-port port) #:verify-certificate? #f
(newline (current-error-port)) #:port port))
result))))) '()))
open-connection-for-uri/maybe)))
(newline (current-error-port))
result))
((file #f) ((file #f)
(let* ((base (string-append (uri-path uri) "/")) (let* ((base (string-append (uri-path uri) "/"))
(files (map (compose (cut string-append base <> ".narinfo") (files (map (compose (cut string-append base <> ".narinfo")
@ -990,10 +999,14 @@ (define %max-cached-connections
(define open-connection-for-uri/cached (define open-connection-for-uri/cached
(let ((cache '())) (let ((cache '()))
(lambda* (uri #:key fresh?) (lambda* (uri #:key fresh? timeout verify-certificate?)
"Return a connection for URI, possibly reusing a cached connection. "Return a connection for URI, possibly reusing a cached connection.
When FRESH? is true, delete any cached connections for URI and open a new When FRESH? is true, delete any cached connections for URI and open a new one.
one. Return #f if URI's scheme is 'file' or #f." 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 host (uri-host uri))
(define scheme (uri-scheme uri)) (define scheme (uri-scheme uri))
(define key (list host scheme (uri-port uri))) (define key (list host scheme (uri-port uri)))
@ -1005,7 +1018,9 @@ (define key (list host scheme (uri-port uri)))
;; CACHE, if any. ;; CACHE, if any.
(let-values (((socket) (let-values (((socket)
(guix:open-connection-for-uri (guix:open-connection-for-uri
uri #:verify-certificate? #f)) uri
#:verify-certificate? verify-certificate?
#:timeout timeout))
((new-cache evicted) ((new-cache evicted)
(at-most (- %max-cached-connections 1) cache))) (at-most (- %max-cached-connections 1) cache)))
(for-each (match-lambda (for-each (match-lambda
@ -1019,14 +1034,19 @@ (define key (list host scheme (uri-port uri)))
(begin (begin
(false-if-exception (close-port socket)) (false-if-exception (close-port socket))
(set! cache (alist-delete key cache)) (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 (begin
;; Drain input left from the previous use. ;; Drain input left from the previous use.
(drain-input socket) (drain-input socket)
socket)))))))) socket))))))))
(define (call-with-cached-connection uri proc) (define* (call-with-cached-connection uri proc
(let ((port (open-connection-for-uri/cached uri))) #:optional
(open-connection
open-connection-for-uri/cached))
(let ((port (open-connection uri)))
(catch #t (catch #t
(lambda () (lambda ()
(proc port)) (proc port))
@ -1038,7 +1058,7 @@ (define (call-with-cached-connection uri proc)
(if (or (and (eq? key 'system-error) (if (or (and (eq? key 'system-error)
(= EPIPE (system-error-errno `(,key ,@args)))) (= EPIPE (system-error-errno `(,key ,@args))))
(memq key '(bad-response bad-header bad-header-component))) (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)))))) (apply throw key args))))))
(define-syntax-rule (with-cached-connection uri port exp ...) (define-syntax-rule (with-cached-connection uri port exp ...)
@ -1341,6 +1361,7 @@ (define deduplicate?
;;; Local Variables: ;;; Local Variables:
;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
;;; eval: (put 'with-cached-connection 'scheme-indent-function 2) ;;; eval: (put 'with-cached-connection 'scheme-indent-function 2)
;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1)
;;; End: ;;; End:
;;; substitute.scm ends here ;;; substitute.scm ends here