From 4663cfd381e278747b28bbb7aebe45ab76e8c984 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 15 May 2023 22:52:25 +0200
Subject: [PATCH] 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'.
---
 guix/import/utils.scm | 33 +++++++++++++++++++++------------
 1 file 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."