ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

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

Commit 205833b72c 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.
This commit is contained in:
Ludovic Courtès 2021-03-27 18:39:28 +01:00
parent 3f4a71a44e
commit 45fce38fb0
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 53 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

75
guix/http-client.scm
View file

@ -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 @@ (define* (http-fetch uri #:key port (text? #f) (buffered? #t)
(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 @@ (define batch
;; 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)))
(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))
(apply throw key args)))))
(connect #f requests result)))
;; Now start processing responses.
(let loop ((sent batch)
@ -219,10 +231,9 @@ (define batch
(remainder
(connect p remainder result))))
((head tail ...)
(catch #t
(lambda ()
(let* ((resp (read-response p))
(body (response-body-port resp))
(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
@ -235,26 +246,12 @@ (define batch
(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
(loop tail (+ 1 processed) result)))))
(#f
(close-port p)
(connect #f ; try again
(drop requests (+ 1 processed))
result))
(apply throw key args))))))))))
result)))))))))
;;;