deploy: Let key-and-args exceptions through.

Fixes <https://bugs.gnu.org/44825>.
Reported by Christopher Lemmer Webber <cwebber@dustycloud.org>.

* guix/ui.scm (guard*): Export.
* guix/scripts/deploy.scm (deploy-machine*): Use 'guard*' instead of
'guard'.  Add '&exception-with-kind-and-args' case.

2 files changed, 23 insertions, 11 deletions

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 1b5be307be..0725fba54b 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -120,17 +120,28 @@ Perform the deployment specified by FILE.\n"))
   (info (G_ "deploying to ~a...~%")
         (machine-display-name machine))
 
-  (guard (c ((message-condition? c)
-             (report-error (G_ "failed to deploy ~a: ~a~%")
-                           (machine-display-name machine)
-                           (condition-message c)))
-            ((deploy-error? c)
-             (when (deploy-error-should-roll-back c)
-               (info (G_ "rolling back ~a...~%")
-                     (machine-display-name machine))
-               (run-with-store store (roll-back-machine machine)))
-             (apply throw (deploy-error-captured-args c))))
-    (run-with-store store (deploy-machine machine))
+  (guard* (c
+           ;; On Guile 3.0, exceptions such as 'unbound-variable' are compound
+           ;; and include a '&message'.  However, that message only contains
+           ;; the format string.  Thus, special-case it here to avoid
+           ;; displaying a bare format string.
+           ((cond-expand
+              (guile-3
+               ((exception-predicate &exception-with-kind-and-args) c))
+              (else #f))
+            (raise c))
+
+           ((message-condition? c)
+            (report-error (G_ "failed to deploy ~a: ~a~%")
+                          (machine-display-name machine)
+                          (condition-message c)))
+           ((deploy-error? c)
+            (when (deploy-error-should-roll-back c)
+              (info (G_ "rolling back ~a...~%")
+                    (machine-display-name machine))
+              (run-with-store store (roll-back-machine machine)))
+            (apply throw (deploy-error-captured-args c))))
+      (run-with-store store (deploy-machine machine))
 
     (info (G_ "successfully deployed ~a~%")
           (machine-display-name machine))))
diff --git a/guix/ui.scm b/guix/ui.scm
index 4e686297e8..0c2c6a5e97 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -101,6 +101,7 @@
             show-what-to-build
             show-what-to-build*
             show-manifest-transaction
+            guard*
             call-with-error-handling
             with-error-handling
             with-unbound-variable-handling