01/03: deploy: Let key-and-args exceptions through.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 5842239a66683b2f5e36e95da8225e2ab7f7dac3
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Nov 26 22:53:08 2020 +0100

    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.
---
 guix/scripts/deploy.scm | 33 ++++++++++++++++++++++-----------
 guix/ui.scm             |  1 +
 2 files changed, 23 insertions(+), 11 deletions(-)

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 1b5be30..0725fba 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 4e68629..0c2c6a5 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