[bug#45409] [PATCH 2/2] substitute: Print backtraces to (current-error-port).

[Christopher Baines]

Otherwise, I believe the backtraces come out in a way that upsets the
guix-daemon. This makes it more difficult to determine what's causing the
issue, see [1] and [2].

1: https://issues.guix.gnu.org/45828
2: https://issues.guix.gnu.org/46362

I'm looking at this now as part of refactoring the code, as just in case
issues crop up, I want it to be clearer where the problem is.

* guix/scripts/substitute.scm (with-exception-handling): New syntax.
(guix-substitute): Wrap main part with with-exception-handling.
---
 guix/scripts/substitute.scm | 83 +++++++++++++++++++++----------------
 1 file changed, 48 insertions(+), 35 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index f98ec8e0d3..ed19e67531 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -226,6 +226,18 @@ was found."
          (args
           (apply throw args)))))))
 
+(define-syntax with-exception-handling
+  (syntax-rules ()
+    "Print the backtrace to the current-error-port and exit"
+    ((_ exp ...)
+     (with-throw-handler #t
+       (lambda () exp ...)
+       (lambda (key . args)
+         (report-error (G_ "substitute: exception raised: ~A: ~A~%") key args)
+         (display-backtrace (make-stack #t) (current-error-port))
+         (newline (current-error-port))
+         (exit 1))))))
+
 
 ;;;
 ;;; Help.
@@ -644,41 +656,42 @@ default value."
         (set-thread-name "guix substitute"))
       (const #t))                                 ;GNU/Hurd lacks 'prctl'
 
-    (with-networking
-     (with-error-handling                         ; for signature errors
-       (match args
-         (("--query")
-          (let ((acl (current-acl)))
-            (let loop ((command (read-line)))
-              (or (eof-object? command)
-                  (begin
-                    (process-query command
-                                   #:cache-urls (substitute-urls)
-                                   #:acl acl)
-                    (loop (read-line)))))))
-         (("--substitute")
-          ;; Download STORE-PATH and store it as a Nar in file DESTINATION.
-          ;; Specify the number of columns of the terminal so the progress
-          ;; report displays nicely.
-          (parameterize ((current-terminal-columns (client-terminal-columns)))
-            (let loop ()
-              (match (read-line)
-                ((? eof-object?)
-                 #t)
-                ((= string-tokenize ("substitute" store-path destination))
-                 (process-substitution store-path destination
-                                       #:cache-urls (substitute-urls)
-                                       #:acl (current-acl)
-                                       #:deduplicate? deduplicate?
-                                       #:print-build-trace?
-                                       print-build-trace?)
-                 (loop))))))
-         ((or ("-V") ("--version"))
-          (show-version-and-exit "guix substitute"))
-         (("--help")
-          (show-help))
-         (opts
-          (leave (G_ "~a: unrecognized options~%") opts)))))))
+    (with-exception-handling
+     (with-networking
+      (with-error-handling                         ; for signature errors
+        (match args
+          (("--query")
+           (let ((acl (current-acl)))
+             (let loop ((command (read-line)))
+               (or (eof-object? command)
+                   (begin
+                     (process-query command
+                                    #:cache-urls (substitute-urls)
+                                    #:acl acl)
+                     (loop (read-line)))))))
+          (("--substitute")
+           ;; Download STORE-PATH and store it as a Nar in file DESTINATION.
+           ;; Specify the number of columns of the terminal so the progress
+           ;; report displays nicely.
+           (parameterize ((current-terminal-columns (client-terminal-columns)))
+             (let loop ()
+               (match (read-line)
+                 ((? eof-object?)
+                  #t)
+                 ((= string-tokenize ("substitute" store-path destination))
+                  (process-substitution store-path destination
+                                        #:cache-urls (substitute-urls)
+                                        #:acl (current-acl)
+                                        #:deduplicate? deduplicate?
+                                        #:print-build-trace?
+                                        print-build-trace?)
+                  (loop))))))
+          ((or ("-V") ("--version"))
+           (show-version-and-exit "guix substitute"))
+          (("--help")
+           (show-help))
+          (opts
+           (leave (G_ "~a: unrecognized options~%") opts))))))))
 
 ;;; Local Variables:
 ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
-- 
2.30.0