From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp1 ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms11 with LMTPS id uGEbB7vYJ2DSVwAA0tVLHw (envelope-from ) for ; Sat, 13 Feb 2021 13:48:43 +0000 Received: from aspmx1.migadu.com ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp1 with LMTPS id 8J7NArvYJ2DIGwAAbx9fmQ (envelope-from ) for ; Sat, 13 Feb 2021 13:48:43 +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 8BA45280FB for ; Sat, 13 Feb 2021 14:48:42 +0100 (CET) Received: from localhost ([::1]:45542 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lAvHs-00035j-Lb for larch@yhetil.org; Sat, 13 Feb 2021 08:48:40 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:55176) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lAvHJ-0002iD-Dt for guix-patches@gnu.org; Sat, 13 Feb 2021 08:48:05 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:50514) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lAvHJ-00077T-3l for guix-patches@gnu.org; Sat, 13 Feb 2021 08:48:05 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lAvHI-0002xK-Um for guix-patches@gnu.org; Sat, 13 Feb 2021 08:48:05 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#45409] [PATCH v5 04/14] guix: Move http-multiple-get to (guix http-client). Resent-From: Christopher Baines Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 13 Feb 2021 13:48:04 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 45409 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 45409@debbugs.gnu.org Received: via spool by 45409-submit@debbugs.gnu.org id=B45409.161322404811216 (code B ref 45409); Sat, 13 Feb 2021 13:48:04 +0000 Received: (at 45409) by debbugs.gnu.org; 13 Feb 2021 13:47:28 +0000 Received: from localhost ([127.0.0.1]:33801 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lAvGi-0002uj-7R for submit@debbugs.gnu.org; Sat, 13 Feb 2021 08:47:28 -0500 Received: from mira.cbaines.net ([212.71.252.8]:48188) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lAvGb-0002sl-Cq for 45409@debbugs.gnu.org; Sat, 13 Feb 2021 08:47:23 -0500 Received: from localhost (unknown [IPv6:2a02:8010:68c1:0:8ac0:b4c7:f5c8:7caa]) by mira.cbaines.net (Postfix) with ESMTPSA id 8D1BE27BC46 for <45409@debbugs.gnu.org>; Sat, 13 Feb 2021 13:47:20 +0000 (GMT) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 14a92826 for <45409@debbugs.gnu.org>; Sat, 13 Feb 2021 13:47:19 +0000 (UTC) From: Christopher Baines Date: Sat, 13 Feb 2021 13:47:09 +0000 Message-Id: <20210213134719.19625-4-mail@cbaines.net> X-Mailer: git-send-email 2.30.0 In-Reply-To: <20210213134719.19625-1-mail@cbaines.net> References: <20210213134719.19625-1-mail@cbaines.net> 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: -1.36 Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=none; 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: 8BA45280FB X-Spam-Score: -1.36 X-Migadu-Scanner: scn0.migadu.com X-TUID: 3F/LMX7LHqxV >From (guix scripts substitute). This will make it easier to reuse this code. * guix/scripts/substitute.scm (http-multiple-get): Remove, and move to… * guix/http-client.scm (http-multiple-get): …here. --- guix/http-client.scm | 76 +++++++++++++++++++++++++++++++++++++ guix/scripts/substitute.scm | 70 ---------------------------------- 2 files changed, 76 insertions(+), 70 deletions(-) diff --git a/guix/http-client.scm b/guix/http-client.scm index 553640fe9e..7ead493633 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -21,8 +21,11 @@ (define-module (guix http-client) #:use-module (web uri) + #:use-module (web http) #:use-module ((web client) #:hide (open-socket-for-uri)) + #:use-module (web request) #:use-module (web response) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) @@ -50,6 +53,7 @@ http-get-error-reason http-fetch + http-multiple-get %http-cache-ttl http-fetch/cached)) @@ -138,6 +142,78 @@ Raise an '&http-get-error' condition if downloading fails." (uri->string uri) code (response-reason-phrase resp)))))))))))) +(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; 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)) + (define batch + (if (>= batch-size (length requests)) + requests + (take requests batch-size))) + + ;; (format (current-error-port) "connecting (~a requests left)..." + ;; (length requests)) + (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))) + + ;; Send BATCH in a row. + ;; XXX: Do our own caching to work around inefficiencies when + ;; communicating over TLS: . + (let-values (((buffer get) (open-bytevector-output-port))) + ;; Inherit the HTTP proxying property from P. + (set-http-proxy-port?! buffer (http-proxy-port? p)) + + (for-each (cut write-request <> buffer) + batch) + (put-bytevector p (get)) + (force-output p)) + + ;; Now start processing responses. + (let loop ((sent batch) + (processed 0) + (result result)) + (match sent + (() + (match (drop requests processed) + (() + (unless keep-alive? + (close-port p)) + (reverse result)) + (remainder + (connect p remainder result)))) + ((head tail ...) + (let* ((resp (read-response p)) + (body (response-body-port resp)) + (result (proc head resp body result))) + ;; The server can choose to stop responding at any time, in which + ;; case we have to try again. Check whether that is the case. + ;; Note that even upon "Connection: close", we can read from BODY. + (match (assq 'connection (response-headers resp)) + (('connection 'close) + (close-port p) + (connect #f ;try again + (drop requests (+ 1 processed)) + result)) + (_ + (loop tail (+ 1 processed) result)))))))))) ;keep going + ;;; ;;; Caching. diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index f01892776e..fc6bb54301 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -299,76 +299,6 @@ return its MAX-LENGTH first elements and its tail." (values (reverse result) lst) (loop (+ 1 len) tail (cons head result))))))) -(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; 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)) - (define batch - (at-most batch-size requests)) - - ;; (format (current-error-port) "connecting (~a requests left)..." - ;; (length requests)) - (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))) - - ;; Send BATCH in a row. - ;; XXX: Do our own caching to work around inefficiencies when - ;; communicating over TLS: . - (let-values (((buffer get) (open-bytevector-output-port))) - ;; Inherit the HTTP proxying property from P. - (set-http-proxy-port?! buffer (http-proxy-port? p)) - - (for-each (cut write-request <> buffer) - batch) - (put-bytevector p (get)) - (force-output p)) - - ;; Now start processing responses. - (let loop ((sent batch) - (processed 0) - (result result)) - (match sent - (() - (match (drop requests processed) - (() - (unless keep-alive? - (close-port p)) - (reverse result)) - (remainder - (connect p remainder result)))) - ((head tail ...) - (let* ((resp (read-response p)) - (body (response-body-port resp)) - (result (proc head resp body result))) - ;; The server can choose to stop responding at any time, in which - ;; case we have to try again. Check whether that is the case. - ;; Note that even upon "Connection: close", we can read from BODY. - (match (assq 'connection (response-headers resp)) - (('connection 'close) - (close-port p) - (connect #f ;try again - (drop requests (+ 1 processed)) - result)) - (_ - (loop tail (+ 1 processed) result)))))))))) ;keep going - (define (read-to-eof port) "Read from PORT until EOF is reached. The data are discarded." (dump-port port (%make-void-port "w"))) -- 2.30.0