[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/04: http-client: 'http-multiple-get' is tail-recursive again.
|
From: |
guix-commits |
|
Subject: |
01/04: http-client: 'http-multiple-get' is tail-recursive again. |
|
Date: |
Sat, 27 Mar 2021 17:53:09 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 45fce38fb0b6c6796906149ade145b8d3594c1c6
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Mar 27 18:39:28 2021 +0100
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.
---
guix/http-client.scm | 109 +++++++++++++++++++++++++--------------------------
1 file changed, 53 insertions(+), 56 deletions(-)
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 4b4c14e..99bbcca 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)))))))))
;;;