From: Christopher Baines <mail@cbaines.net>
To: 45409@debbugs.gnu.org
Subject: [bug#45409] [PATCH v4 04/13] guix: Move http-multiple-get to (guix http-client).
Date: Sat, 16 Jan 2021 13:57:54 +0000 [thread overview]
Message-ID: <20210116135803.21955-4-mail@cbaines.net> (raw)
In-Reply-To: <20210116135803.21955-1-mail@cbaines.net>
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: <http://bugs.gnu.org/22966>.
+ (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
+
\f
;;;
;;; Caching.
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index ecc2bd9035..64b8ae2a15 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: <http://bugs.gnu.org/22966>.
- (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
next prev parent reply other threads:[~2021-01-16 13:59 UTC|newest]
Thread overview: 56+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-12-24 17:17 [bug#45409] [PATCH 0/3] Move some (guix scripts substitute) code to two new modules Christopher Baines
2020-12-24 17:22 ` [bug#45409] [PATCH 1/3] guix: Move narinfo code from substitute script to module Christopher Baines
2020-12-24 17:22 ` [bug#45409] [PATCH 2/3] guix: Untangle (guix narinfo) from (guix scripts substitute) Christopher Baines
2020-12-24 17:22 ` [bug#45409] [PATCH 3/3] guix: Split (guix substitute) " Christopher Baines
2021-01-03 15:08 ` Ludovic Courtès
2021-01-03 18:19 ` Christopher Baines
2021-01-03 15:03 ` [bug#45409] [PATCH 1/3] guix: Move narinfo code from substitute script to module Ludovic Courtès
2021-01-03 18:16 ` Christopher Baines
2021-01-04 21:24 ` Christopher Baines
2021-01-03 17:59 ` [bug#45409] [PATCH v2 1/3] substitute: Untangle skipping authentication from valid-narinfo? Christopher Baines
2021-01-03 17:59 ` [bug#45409] [PATCH v2 2/3] guix: Move narinfo code from substitute script to module Christopher Baines
2021-01-03 17:59 ` [bug#45409] [PATCH v2 3/3] guix: Split (guix substitutes) from (guix scripts substitute) Christopher Baines
2021-01-04 21:19 ` [bug#45409] [PATCH v3 1/3] substitute: Untangle skipping authentication from valid-narinfo? Christopher Baines
2021-01-04 21:19 ` [bug#45409] [PATCH v3 2/3] guix: Move narinfo code from substitute script to module Christopher Baines
2021-01-05 21:58 ` Ludovic Courtès
2021-01-04 21:19 ` [bug#45409] [PATCH v3 3/3] guix: Split (guix substitutes) from (guix scripts substitute) Christopher Baines
2021-01-05 22:03 ` Ludovic Courtès
2021-01-07 22:29 ` Christopher Baines
2021-01-11 13:26 ` Ludovic Courtès
2021-01-16 14:18 ` Christopher Baines
2021-02-13 13:56 ` Christopher Baines
2021-02-22 22:21 ` Christopher Baines
2021-02-23 20:46 ` Christopher Baines
2021-01-05 21:57 ` [bug#45409] [PATCH v3 1/3] substitute: Untangle skipping authentication from valid-narinfo? Ludovic Courtès
2021-01-05 22:58 ` Christopher Baines
2021-01-06 8:37 ` Ludovic Courtès
2021-01-16 13:57 ` [bug#45409] [PATCH v4 01/13] substitute: Remove buffer handling from fetch Christopher Baines
2021-01-16 13:57 ` [bug#45409] [PATCH v4 02/13] substitute: Remove connection " Christopher Baines
2021-01-16 13:57 ` [bug#45409] [PATCH v4 03/13] substitute: Remove redundant let block " Christopher Baines
2021-01-16 13:57 ` Christopher Baines [this message]
2021-01-16 13:57 ` [bug#45409] [PATCH v4 05/13] http-client: Add error handling to http-multiple-get Christopher Baines
2021-01-16 13:57 ` [bug#45409] [PATCH v4 06/13] substitute: open-connection-for-uri/maybe add #:verify-certificate? Christopher Baines
2021-01-16 13:57 ` [bug#45409] [PATCH v4 07/13] substitute: Stop using call-with-cached-connection in fetch-narinfos Christopher Baines
2021-01-16 13:57 ` [bug#45409] [PATCH v4 08/13] http-client: Accept #:open-connection in http-fetch Christopher Baines
2021-01-16 13:57 ` [bug#45409] [PATCH v4 09/13] substitute: Change connection cache handling in process-substitution Christopher Baines
2021-01-16 13:58 ` [bug#45409] [PATCH v4 10/13] substitute: Remove now redundant connection caching helpers Christopher Baines
2021-01-16 13:58 ` [bug#45409] [PATCH v4 11/13] substitute: Remove redundant fetch arguments Christopher Baines
2021-01-16 13:58 ` [bug#45409] [PATCH v4 12/13] substitute: Inline fetch in to process-substitutes Christopher Baines
2021-01-16 13:58 ` [bug#45409] [PATCH v4 13/13] substitute: Remove fetch-narinfos use open-connection-for-uri/maybe Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 01/14] substitute: Remove buffer handling from fetch Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 02/14] substitute: Remove connection " Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 03/14] substitute: Remove redundant let block " Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 04/14] guix: Move http-multiple-get to (guix http-client) Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 05/14] http-client: Add error handling to http-multiple-get Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 06/14] substitute: open-connection-for-uri/maybe add #:verify-certificate? Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 07/14] substitute: Stop using call-with-cached-connection in fetch-narinfos Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 08/14] http-client: Accept #:open-connection in http-fetch Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 09/14] substitute: Change connection cache handling in process-substitution Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 10/14] substitute: Remove now redundant connection caching helpers Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 11/14] substitute: Remove redundant fetch arguments Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 12/14] substitute: Inline fetch in to process-substitutes Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 13/14] substitute: Remove fetch-narinfos use open-connection-for-uri/maybe Christopher Baines
2021-02-13 13:47 ` [bug#45409] [PATCH v5 14/14] substitute: Rework connection error handling Christopher Baines
2021-02-23 19:59 ` [bug#45409] [PATCH 1/2] guix: Split (guix substitutes) from (guix scripts substitute) Christopher Baines
2021-02-23 19:59 ` [bug#45409] [PATCH 2/2] substitute: Print backtraces to (current-error-port) Christopher Baines
2021-03-06 0:57 ` bug#45409: [PATCH 0/3] Move some (guix scripts substitute) code to two new modules Christopher Baines
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20210116135803.21955-4-mail@cbaines.net \
--to=mail@cbaines.net \
--cc=45409@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.