import: utils: 'call-with-networking-exception-handler' doesn't unwind.

That way backtraces show where the error actually originates from.

* guix/import/utils.scm (call-with-networking-exception-handler):
Rewrite using 'with-exception-handler'.
This commit is contained in:
Ludovic Courtès 2023-05-15 22:52:25 +02:00
parent d2f36abd02
commit 4663cfd381
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 21 additions and 12 deletions

View File

@ -45,6 +45,7 @@
#:use-module (guix sets)
#:use-module ((guix ui) #:select (fill-paragraph))
#:use-module (gnu packages)
#:autoload (ice-9 control) (let/ec)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
@ -126,18 +127,26 @@ of the string VERSION is replaced by the symbol 'version."
(define (call-with-networking-exception-handler thunk)
"Invoke THUNK, returning #f if one of the usual networking exception is
thrown."
(catch #t
(lambda ()
(guard (c ((http-get-error? c) #f))
(thunk)))
(lambda (key . args)
;; Return false and move on upon connection failures and bogus HTTP
;; servers.
(unless (memq key '(gnutls-error tls-certificate-error
system-error getaddrinfo-error
bad-header bad-header-component))
(apply throw key args))
#f)))
(let/ec return
(with-exception-handler
(lambda (exception)
(cond ((http-get-error? exception)
(return #f))
(((exception-predicate &exception-with-kind-and-args) exception)
;; Return false and move on upon connection failures and bogus
;; HTTP servers.
(if (memq (exception-kind exception)
'(gnutls-error tls-certificate-error
system-error getaddrinfo-error
bad-header bad-header-component))
(return #f)
(raise-exception exception)))
(else
(raise-exception exception))))
thunk
;; Do not unwind to preserve meaningful backtraces.
#:unwind? #f)))
(define-syntax-rule (false-if-networking-error exp)
"Evaluate EXP, returning #f if a networking-related exception is thrown."