use trivial-backtrace to get a backtrace for forked process failures

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

4 files changed, 27 insertions, 25 deletions

diff --git a/consfigurator.asd b/consfigurator.asd
index 2f5ac38..ea9487f 100644
--- a/consfigurator.asd
+++ b/consfigurator.asd
@@ -12,6 +12,7 @@
                #:cl-interpol
                #:named-readtables
                #:cffi
+               #:trivial-backtrace
                #:trivial-macroexpand-all)
   :components ((:file "src/package")
                (:file "src/reader")
diff --git a/debian/changelog b/debian/changelog
index 3203c14..37839f0 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,6 +1,7 @@
 consfigurator (0.4.0-1) UNRELEASED; urgency=medium
 
-  * Add deps and build-deps on cl-heredoc and cl-named-readtables.
+  * Add deps and build-deps on cl-heredoc, cl-named-readtables,
+    cl-trivial-backtrace.
 
  -- Sean Whitton <spwhitton@spwhitton.name>  Sat, 20 Mar 2021 12:31:53 -0700
 
diff --git a/debian/control b/debian/control
index 3ca533c..916974b 100644
--- a/debian/control
+++ b/debian/control
@@ -10,6 +10,7 @@ Build-Depends:
  cl-interpol,
  cl-named-readtables,
  cl-ppcre,
+ cl-trivial-backtrace,
  cl-trivial-macroexpand-all,
  debhelper-compat (= 13),
  dh-elpa,
@@ -33,6 +34,7 @@ Depends:
  cl-interpol,
  cl-named-readtables,
  cl-ppcre,
+ cl-trivial-backtrace,
  cl-trivial-macroexpand-all,
  emacsen-common,
  ${misc:Depends},
diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp
index a147b10..87355c9 100644
--- a/src/connection/fork.lisp
+++ b/src/connection/fork.lisp
@@ -58,30 +58,28 @@ for example, such that we don't see it."
          (-1
           (error "fork(2) failed"))
          (0
-          (handler-case
-              (progn
-                ;; TODO either (reset-data-sources), or bind a restart to
-                ;; convert data source errors into failed-change (or ignore
-                ;; them?  or what?), as they may or may not be available
-                ;; inside the chroot, depending on whether the data source
-                ;; code needs to read files outside of the chroot or already
-                ;; has the data cached, a socket open etc.
-                (mapc #'clear-input
-                      (list *standard-input* *debug-io* *terminal-io*))
-                (reset-remote-home)
-                ,@forms
-                ;; it would be nice to reenter Consfigurator's primary loop by
-                ;; just calling (return-from establish-connection
-                ;; (establish-connection :local)) here, but we need to kill
-                ;; off the child afterwards, rather than returning to the
-                ;; child's REPL or whatever else
-                (continue-deploy* ,remaining)
-                (uiop:quit 0))
-            ;; TODO With this approach we don't get the backtrace leading up
-            ;; to the serious condition.
-            (serious-condition (c)
-              (format *error-output* "Fork connection child failed: ~A~%" c)
-              (uiop:quit 2))))
+          (handler-bind ((serious-condition
+                           (lambda (c)
+                             (trivial-backtrace:print-backtrace
+                              c :output *error-output*)
+                             (uiop:quit 2))))
+            ;; TODO either (reset-data-sources), or bind a restart to
+            ;; convert data source errors into failed-change (or ignore
+            ;; them?  or what?), as they may or may not be available
+            ;; inside the chroot, depending on whether the data source
+            ;; code needs to read files outside of the chroot or already
+            ;; has the data cached, a socket open etc.
+            (mapc #'clear-input
+                  (list *standard-input* *debug-io* *terminal-io*))
+            (reset-remote-home)
+            ,@forms
+            ;; it would be nice to reenter Consfigurator's primary loop by
+            ;; just calling (return-from establish-connection
+            ;; (establish-connection :local)) here, but we need to kill
+            ;; off the child afterwards, rather than returning to the
+            ;; child's REPL or whatever else
+            (continue-deploy* ,remaining)
+            (uiop:quit 0)))
          (t
           (multiple-value-bind (_ status) (waitpid child 0)
             (declare (ignore _))