[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#47288] [PATCH v3 2/2] guix: http-client: Refactor http-multiple-get
|
From: |
Christopher Baines |
|
Subject: |
[bug#47288] [PATCH v3 2/2] guix: http-client: Refactor http-multiple-get. |
|
Date: |
Thu, 25 Mar 2021 11:03:16 +0000 |
Split the procedure in to three smaller procedures, rather than using two
longer let statements. This might make it easier to read.
* guix/http-client.scm (http-multiple-get): Refactor.
---
guix/http-client.scm | 195 ++++++++++++++++++++++---------------------
1 file changed, 101 insertions(+), 94 deletions(-)
diff --git a/guix/http-client.scm b/guix/http-client.scm
index adbfbc0d6e..b584feba5d 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -147,7 +147,7 @@ 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
+(define* (http-multiple-get base-uri proc seed all-requests
#:key port (verify-certificate? #t)
(open-connection guix:open-connection-for-uri)
(keep-alive? #t)
@@ -161,16 +161,90 @@ 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 (send-batch-of-requests p batch)
+ ;; 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)))
+
+ (define (process-batch-of-responses p
+ all-remaining-requests
+ batch-remaining-requests
+ processed
+ result)
+ (if (null? batch-remaining-requests)
+ (match (drop all-remaining-requests processed)
+ (()
+ (unless keep-alive?
+ (close-port p))
+ (reverse result))
+ (remainder
+ (connect-and-make-requests p remainder result)))
+ (match
+ (catch #t
+ (lambda ()
+ (let* ((request (car batch-remaining-requests))
+ (resp (read-response p))
+ (body (response-body-port resp))
+ (result (proc request 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)
+ (list 'connect-and-make-requests
+ #f
+ (drop all-remaining-requests (+ 1 processed))
+ result))
+ (_
+ (list 'process-batch-of-responses
+ p
+ all-remaining-requests
+ (cdr batch-remaining-requests)
+ (+ 1 processed)
+ result)))))
+ (lambda (key . args)
+ ;; If PORT was cached and the server closed the connection in
+ ;; the meantime, we get EPIPE. In that case, open a fresh
+ ;; connection and retry. We might also get 'bad-response or a
+ ;; similar exception from (web response) later on, once we've
+ ;; sent the request, or a ERROR/INVALID-SESSION from GnuTLS.
+ (if (or (and (eq? key 'system-error)
+ (= EPIPE (system-error-errno `(,key ,@args))))
+ (and (eq? key 'gnutls-error)
+ (eq? (first args) error/invalid-session))
+ (memq key
+ '(bad-response
+ bad-header
+ bad-header-component)))
+ (begin
+ (close-port p)
+ (list 'connect-and-make-requests
+ #f
+ (drop all-remaining-requests processed)
+ result))
+ (apply throw key args))))
+
+ (('connect-and-make-requests . args)
+ (apply connect-and-make-requests args))
+ (('process-batch-of-responses . args)
+ (apply process-batch-of-responses args)))))
+
+ (define (connect-and-make-requests port remaining-requests result)
(define batch
- (if (>= batch-size (length requests))
- requests
- (take requests batch-size)))
+ (if (>= batch-size (length remaining-requests))
+ remaining-requests
+ (take remaining-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?))))
@@ -178,92 +252,25 @@ returning."
(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))
-
- (catch #t
- (lambda ()
- (for-each (cut write-request <> buffer)
- batch)
- (put-bytevector p (get))
- (force-output p))
- (lambda (key . args)
- ;; If PORT becomes unusable, open a fresh connection and
- ;; retry.
- (if (or (and (eq? key 'system-error)
- (= EPIPE (system-error-errno `(,key ,@args))))
- (and (eq? key 'gnutls-error)
- (eq? (first args) error/invalid-session)))
- (begin
- (close-port p) ; close the broken port
- (connect #f
- requests
- result))
- (apply throw key args)))))
+ (catch #t
+ (lambda ()
+ (send-batch-of-requests p batch))
+ (lambda (key . args)
+ ;; If PORT becomes unusable, open a fresh connection and retry.
+ (if (or (and (eq? key 'system-error)
+ (= EPIPE (system-error-errno `(,key ,@args))))
+ (and (eq? key 'gnutls-error)
+ (eq? (first args) error/invalid-session)))
+ (begin
+ (close-port p) ; close the broken port
+ (connect-and-make-requests #f
+ remaining-requests
+ result))
+ (apply throw key args))))
- ;; 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 ...)
- (match
- (catch #t
- (lambda ()
- (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)
- (list 'connect
- #f
- (drop requests (+ 1 processed))
- result))
- (_
- (list 'loop tail (+ 1 processed) result)))))
- (lambda (key . args)
- ;; If PORT was cached and the server closed the connection
- ;; in the meantime, we get EPIPE. In that case, open a
- ;; fresh connection and retry. We might also get
- ;; 'bad-response or a similar exception from (web response)
- ;; later on, once we've sent the request, or a
- ;; ERROR/INVALID-SESSION from GnuTLS.
- (if (or (and (eq? key 'system-error)
- (= EPIPE (system-error-errno `(,key ,@args))))
- (and (eq? key 'gnutls-error)
- (eq? (first args) error/invalid-session))
- (memq key
- '(bad-response
- bad-header
- bad-header-component)))
- (begin
- (close-port p)
- (list 'connect
- #f
- (drop requests processed)
- result))
- (apply throw key args))))
- (('connect . args)
- (apply connect args))
- (('loop . args)
- (apply loop args)))))))))
+ (process-batch-of-responses p remaining-requests batch 0 result)))
+
+ (connect-and-make-requests port all-requests seed))
;;;
--
2.30.1