kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

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

Browse Source 
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.
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

109
guix/http-client.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; 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 (uri->string uri) code
(response-reason-phrase resp)))))))))))) (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 (define* (http-multiple-get base-uri proc seed requests
#:key port (verify-certificate? #t) #:key port (verify-certificate? #t)
(open-connection guix:open-connection-for-uri) (open-connection guix:open-connection-for-uri)
@ -185,25 +207,15 @@ returning."
;; Inherit the HTTP proxying property from P. ;; Inherit the HTTP proxying property from P.
(set-http-proxy-port?! buffer (http-proxy-port? p)) (set-http-proxy-port?! buffer (http-proxy-port? p))
(catch #t (unless (false-if-networking-error
(lambda () (begin
(for-each (cut write-request <> buffer) (for-each (cut write-request <> buffer) batch)
batch) (put-bytevector p (get))
(put-bytevector p (get)) (force-output p)
(force-output p)) #t))
(lambda (key . args) ;; If PORT becomes unusable, open a fresh connection and retry.
;; If PORT becomes unusable, open a fresh connection and (close-port p) ; close the broken port
;; retry. (connect #f requests result)))
(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)))))
;; Now start processing responses. ;; Now start processing responses.
(let loop ((sent batch) (let loop ((sent batch)
@ -219,42 +231,27 @@ returning."
(remainder (remainder
(connect p remainder result)))) (connect p remainder result))))
((head tail ...) ((head tail ...)
(catch #t (match (false-if-networking-error (read-response p))
(lambda () ((? response? resp)
(let* ((resp (read-response p)) (let* ((body (response-body-port resp))
(body (response-body-port resp)) (result (proc head resp body result)))
(result (proc head resp body result))) ;; The server can choose to stop responding at any time,
;; The server can choose to stop responding at any time, ;; in which case we have to try again. Check whether
;; in which case we have to try again. Check whether ;; that is the case. Note that even upon "Connection:
;; that is the case. Note that even upon "Connection: ;; close", we can read from BODY.
;; close", we can read from BODY. (match (assq 'connection (response-headers resp))
(match (assq 'connection (response-headers resp)) (('connection 'close)
(('connection 'close) (close-port p)
(close-port p) (connect #f ;try again
(connect #f ;try again (drop requests (+ 1 processed))
(drop requests (+ 1 processed)) result))
result)) (_
(_ (loop tail (+ 1 processed) result)))))
(loop tail (+ 1 processed) result))))) ;keep going (#f
(lambda (key . args) (close-port p)
;; If PORT was cached and the server closed the connection (connect #f ; try again
;; in the meantime, we get EPIPE. In that case, open a (drop requests (+ 1 processed))
;; fresh connection and retry. We might also get result)))))))))
;; '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))))))))))
;;; ;;;