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

substitute: Rethrow with 'raise-exception', not 'throw'.

Browse source 
Rethrowing with 'throw' doesn't work as intended when the exception
being rethrown is a SRFI-34 exception.

Fixes <https://issues.guix.gnu.org/55820>.

* guix/scripts/substitute.scm (kind-and-args-exception?): New variable.
(call-with-cached-connection): Rewrite using 'guard' instead of 'catch'
and 'raise' instead of 'throw'.
(system-error?): Use 'kind-and-args-exception?' instead of local
definition.
This commit is contained in:
Ludovic Courtès 2023-05-22 12:15:14 +02:00
parent 88a2871d8f
commit 3f59fd6d11
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 35 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

65
guix/scripts/substitute.scm
View file

@ -400,34 +400,41 @@ (define key (list host scheme (uri-port uri)))
(drain-input socket) (drain-input socket)
socket)))))))) socket))))))))
(define kind-and-args-exception?
(exception-predicate &exception-with-kind-and-args))
(define (call-with-cached-connection uri proc) (define (call-with-cached-connection uri proc)
(let ((port (open-connection-for-uri/cached uri (let ((port (open-connection-for-uri/cached uri
#:verify-certificate? #f))) #:verify-certificate? #f)))
(catch #t (guard (c ((kind-and-args-exception? c)
(lambda () (let ((key (exception-kind c))
(proc port)) (args (exception-args c)))
(lambda (key . args) ;; If PORT was cached and the server closed the connection in the
;; If PORT was cached and the server closed the connection in the ;; meantime, we get EPIPE. In that case, open a fresh connection
;; meantime, we get EPIPE. In that case, open a fresh connection ;; and retry. We might also get 'bad-response or a similar
;; and retry. We might also get 'bad-response or a similar ;; exception from (web response) later on, once we've sent the
;; exception from (web response) later on, once we've sent the ;; request, or a ERROR/INVALID-SESSION from GnuTLS.
;; request, or a ERROR/INVALID-SESSION from GnuTLS. (if (or (and (eq? key 'system-error)
(if (or (and (eq? key 'system-error) (= EPIPE (system-error-errno `(,key ,@args))))
(= EPIPE (system-error-errno `(,key ,@args)))) (and (eq? key 'gnutls-error)
(and (eq? key 'gnutls-error) (memq (first args)
(memq (first args) (list error/invalid-session
(list error/invalid-session
;; XXX: These two are not properly handled in ;; XXX: These two are not properly handled in
;; GnuTLS < 3.7.3, in ;; GnuTLS < 3.7.3, in
;; 'write_to_session_record_port'; see ;; 'write_to_session_record_port'; see
;; <https://bugs.gnu.org/47867>. ;; <https://bugs.gnu.org/47867>.
error/again error/interrupted))) error/again error/interrupted)))
(memq key '(bad-response bad-header bad-header-component))) (memq key '(bad-response bad-header bad-header-component)))
(proc (open-connection-for-uri/cached uri (proc (open-connection-for-uri/cached uri
#:verify-certificate? #f #:verify-certificate? #f
#:fresh? #t)) #:fresh? #t))
(apply throw key args)))))) (raise c))))
(#t
;; An exception that's not handled here, such as
;; '&http-get-error'. Re-raise it.
(raise c)))
(proc port))))
(define-syntax-rule (with-cached-connection uri port exp ...) (define-syntax-rule (with-cached-connection uri port exp ...)
"Bind PORT with EXP... to a socket connected to URI." "Bind PORT with EXP... to a socket connected to URI."
@ -563,12 +570,10 @@ (define cpu-usage
(bytevector->nix-base32-string expected) (bytevector->nix-base32-string expected)
(bytevector->nix-base32-string actual))))))) (bytevector->nix-base32-string actual)))))))
(define system-error? (define (system-error? exception)
(let ((kind-and-args? (exception-predicate &exception-with-kind-and-args))) "Return true if EXCEPTION is a Guile 'system-error exception."
(lambda (exception) (and (kind-and-args-exception? exception)
"Return true if EXCEPTION is a Guile 'system-error exception." (eq? 'system-error (exception-kind exception))))
(and (kind-and-args? exception)
(eq? 'system-error (exception-kind exception))))))
(define network-error? (define network-error?
(let ((kind-and-args? (exception-predicate &exception-with-kind-and-args))) (let ((kind-and-args? (exception-predicate &exception-with-kind-and-args)))