guix: http-client: Refactor http-multiple-get.tweak-http-multiple-get-error-handling

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.

1 files 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))
 
 
 ;;;