diff options
author | Ludovic Courtès <ludo@gnu.org> | 2023-05-15 22:52:25 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2023-05-31 23:25:24 +0200 |
commit | 4663cfd381e278747b28bbb7aebe45ab76e8c984 (patch) | |
tree | 6e8ea9c26953159b6f2af85915301a60f5b9f25e /guix/import | |
parent | d2f36abd02088cdf1ceb26de2de9c2b33f50c09e (diff) | |
download | guix-patches-4663cfd381e278747b28bbb7aebe45ab76e8c984.tar guix-patches-4663cfd381e278747b28bbb7aebe45ab76e8c984.tar.gz |
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'.
Diffstat (limited to 'guix/import')
-rw-r--r-- | guix/import/utils.scm | 33 |
1 files changed, 21 insertions, 12 deletions
diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 177817b10c..e9a0a7ecd7 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -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." |