http-client: 'http-multiple-get' is tail-recursive again.

Fixes <https://bugs.gnu.org/47283>.

Commit 205833b72c5517915a47a50dbe28e7024dc74e57 made 'http-multiple-get'
non-tail-recursive.  Each recursive call would install an exception
handler.  As the number of iterations grows beyond 1,000, quadratic
complexity of 'raise-exception' would show and we'd spend most of our
time there.

* guix/http-client.scm (false-if-networking-error): New macro.
(http-multiple-get): Use it around 'write-request' and 'put-bytevector'
calls, and around 'read-response' call, in lieu of the inline 'catch'
forms.

1 files changed, 53 insertions, 56 deletions

diff --git a/guix/http-client.scm b/guix/http-client.scm
index 4b4c14ed0b..99bbccafd6 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
@@ -147,6 +147,28 @@ Raise an '&http-get-error' condition if downloading fails."
                                 (uri->string uri) code
                                 (response-reason-phrase resp))))))))))))
 
+(define-syntax-rule (false-if-networking-error exp)
+  "Return #f if EXP triggers a network related exception as can occur when
+reusing stale cached connections."
+  ;; FIXME: Duplicated from 'with-cached-connection'.
+  (catch #t
+    (lambda ()
+      exp)
+    (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)))
+          #f
+          (apply throw key args)))))
+
 (define* (http-multiple-get base-uri proc seed requests
                             #:key port (verify-certificate? #t)
                             (open-connection guix:open-connection-for-uri)
@@ -185,25 +207,15 @@ returning."
         ;; 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)))))
+        (unless (false-if-networking-error
+                 (begin
+                   (for-each (cut write-request <> buffer) batch)
+                   (put-bytevector p (get))
+                   (force-output p)
+                   #t))
+          ;; If PORT becomes unusable, open a fresh connection and retry.
+          (close-port p)                          ; close the broken port
+          (connect #f requests result)))
 
       ;; Now start processing responses.
       (let loop ((sent      batch)
@@ -219,42 +231,27 @@ returning."
              (remainder
               (connect p remainder result))))
           ((head tail ...)
-           (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)
-                    (connect #f                       ;try again
-                             (drop requests (+ 1 processed))
-                             result))
-                   (_
-                    (loop tail (+ 1 processed) result))))) ;keep going
-             (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)
-                     (connect #f      ; try again
-                              (drop requests (+ 1 processed))
-                              result))
-                   (apply throw key args))))))))))
+           (match (false-if-networking-error (read-response p))
+             ((? response? resp)
+              (let* ((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)))))
+             (#f
+              (close-port p)
+              (connect #f                         ; try again
+                       (drop requests (+ 1 processed))
+                       result)))))))))
 
 
 ;;;