From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp0 ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms11 with LMTPS id 6DLPM14T3l/jRQAA0tVLHw (envelope-from ) for ; Sat, 19 Dec 2020 14:51:10 +0000 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp0 with LMTPS id OBekL14T3l+JHAAA1q6Kng (envelope-from ) for ; Sat, 19 Dec 2020 14:51:10 +0000 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id DFB279403A6 for ; Sat, 19 Dec 2020 14:51:09 +0000 (UTC) Received: from localhost ([::1]:52938 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kqdZc-0006Sq-QN for larch@yhetil.org; Sat, 19 Dec 2020 09:51:08 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:55780) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kqdZW-0006SA-5t for guix-patches@gnu.org; Sat, 19 Dec 2020 09:51:02 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:57784) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kqdZV-0000r8-TR for guix-patches@gnu.org; Sat, 19 Dec 2020 09:51:01 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kqdZV-0001qF-RK for guix-patches@gnu.org; Sat, 19 Dec 2020 09:51:01 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#45323] [PATCH] substitute: Reuse connections for '--query'. Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 19 Dec 2020 14:51:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 45323 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 45323@debbugs.gnu.org X-Debbugs-Original-To: guix-patches@gnu.org Received: via spool by submit@debbugs.gnu.org id=B.16083894047000 (code B ref -1); Sat, 19 Dec 2020 14:51:01 +0000 Received: (at submit) by debbugs.gnu.org; 19 Dec 2020 14:50:04 +0000 Received: from localhost ([127.0.0.1]:41097 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kqdYZ-0001on-Fx for submit@debbugs.gnu.org; Sat, 19 Dec 2020 09:50:04 -0500 Received: from lists.gnu.org ([209.51.188.17]:47080) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kqdYW-0001oJ-2E for submit@debbugs.gnu.org; Sat, 19 Dec 2020 09:50:02 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:55652) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kqdYV-0006LY-N6 for guix-patches@gnu.org; Sat, 19 Dec 2020 09:49:59 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:56516) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kqdYU-0000Nj-Pr; Sat, 19 Dec 2020 09:49:58 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=51302 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1kqdYU-0002Hd-A9; Sat, 19 Dec 2020 09:49:58 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sat, 19 Dec 2020 15:49:52 +0100 Message-Id: <20201219144952.2725-1-ludo@gnu.org> X-Mailer: git-send-email 2.29.2 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Migadu-Flow: FLOW_IN X-Migadu-Spam-Score: -0.32 Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Migadu-Queue-Id: DFB279403A6 X-Spam-Score: -0.32 X-Migadu-Scanner: scn0.migadu.com X-TUID: L829DjhyTF4i This significantly speeds up things like substituting the closure of a .drv. This is a followup to 5ff521452b9ec2aae9ed8e4bb7bdc250a581f203. * 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. --- guix/scripts/substitute.scm | 97 ++++++++++++++++++++++--------------- 1 file changed, 59 insertions(+), 38 deletions(-) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 38702d0c4b..8084c89ae5 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -514,12 +514,18 @@ return its MAX-LENGTH first elements and its tail." (define* (http-multiple-get base-uri proc seed requests #:key port (verify-certificate? #t) + (open-connection guix:open-connection-for-uri) + (keep-alive? #t) (batch-size 1000)) "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. When PORT is specified, use it as the -initial connection on which HTTP requests are sent." +'fold'. Return the final result. + +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) (requests requests) (result seed)) @@ -528,10 +534,9 @@ initial connection on which HTTP requests are sent." ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) - (let ((p (or port (guix:open-connection-for-uri - base-uri - #:verify-certificate? - verify-certificate?)))) + (let ((p (or port (open-connection base-uri + #:verify-certificate? + verify-certificate?)))) ;; For HTTPS, P is not a file port and does not support 'setvbuf'. (when (file-port? p) (setvbuf p 'block (expt 2 16))) @@ -556,7 +561,8 @@ initial connection on which HTTP requests are sent." (() (match (drop requests processed) (() - (close-port p) + (unless keep-alive? + (close-port p)) (reverse result)) (remainder (connect p remainder result)))) @@ -598,18 +604,18 @@ if file doesn't exist, and the narinfo otherwise." (define* (open-connection-for-uri/maybe uri #:key - (verify-certificate? #f) + fresh? (time %fetch-timeout)) - "Open a connection to URI and return a port to it, or, if connection failed, -print a warning and return #f." + "Open a connection to URI via 'open-connection-for-uri/cached' and return a +port to it, or, if connection failed, print a warning and return #f. Pass +#:fresh? to 'open-connection-for-uri/cached'." (define host (uri-host uri)) (catch #t (lambda () - (guix:open-connection-for-uri uri - #:verify-certificate? verify-certificate? - #:timeout time)) + (open-connection-for-uri/cached uri #:timeout time + #:fresh? fresh?)) (match-lambda* (('getaddrinfo-error error) (unless (hash-ref %unreachable-hosts host) @@ -683,23 +689,26 @@ print a warning and return #f." (define (do-fetch uri) (case (and=> uri uri-scheme) ((http https) - (let ((requests (map (cut narinfo-request url <>) paths))) - (match (open-connection-for-uri/maybe uri) - (#f - '()) - (port - (update-progress!) - ;; Note: Do not check HTTPS server certificates to avoid depending - ;; on the X.509 PKI. We can do it because we authenticate - ;; narinfos, which provides a much stronger guarantee. - (let ((result (http-multiple-get uri - handle-narinfo-response '() - requests - #:verify-certificate? #f - #:port port))) - (close-port port) - (newline (current-error-port)) - result))))) + ;; Note: Do not check HTTPS server certificates to avoid depending + ;; on the X.509 PKI. We can do it because we authenticate + ;; narinfos, which provides a much stronger guarantee. + (let* ((requests (map (cut narinfo-request url <>) paths)) + (result (call-with-cached-connection uri + (lambda (port) + (if port + (begin + (update-progress!) + (http-multiple-get uri + handle-narinfo-response '() + requests + #:open-connection + open-connection-for-uri/cached + #:verify-certificate? #f + #:port port)) + '())) + open-connection-for-uri/maybe))) + (newline (current-error-port)) + result)) ((file #f) (let* ((base (string-append (uri-path uri) "/")) (files (map (compose (cut string-append base <> ".narinfo") @@ -990,10 +999,14 @@ the URI, its compression method (a string), and the compressed file size." (define open-connection-for-uri/cached (let ((cache '())) - (lambda* (uri #:key fresh?) + (lambda* (uri #:key fresh? timeout verify-certificate?) "Return a connection for URI, possibly reusing a cached connection. -When FRESH? is true, delete any cached connections for URI and open a new -one. Return #f if URI's scheme is 'file' or #f." +When FRESH? is true, delete any cached connections for URI and open a new one. +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 scheme (uri-scheme uri)) (define key (list host scheme (uri-port uri))) @@ -1005,7 +1018,9 @@ one. Return #f if URI's scheme is 'file' or #f." ;; CACHE, if any. (let-values (((socket) (guix:open-connection-for-uri - uri #:verify-certificate? #f)) + uri + #:verify-certificate? verify-certificate? + #:timeout timeout)) ((new-cache evicted) (at-most (- %max-cached-connections 1) cache))) (for-each (match-lambda @@ -1019,14 +1034,19 @@ one. Return #f if URI's scheme is 'file' or #f." (begin (false-if-exception (close-port socket)) (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 ;; Drain input left from the previous use. (drain-input socket) socket)))))))) -(define (call-with-cached-connection uri proc) - (let ((port (open-connection-for-uri/cached uri))) +(define* (call-with-cached-connection uri proc + #:optional + (open-connection + open-connection-for-uri/cached)) + (let ((port (open-connection uri))) (catch #t (lambda () (proc port)) @@ -1038,7 +1058,7 @@ one. Return #f if URI's scheme is 'file' or #f." (if (or (and (eq? key 'system-error) (= EPIPE (system-error-errno `(,key ,@args)))) (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)))))) (define-syntax-rule (with-cached-connection uri port exp ...) @@ -1341,6 +1361,7 @@ default value." ;;; Local Variables: ;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; eval: (put 'with-cached-connection 'scheme-indent-function 2) +;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1) ;;; End: ;;; substitute.scm ends here -- 2.29.2