[bug#75010] [PATCH 5/7] gnu: machine: Remove &deploy-error.

[Herman Rimm via Guix-patches via <guix-patches@gnu.org>]

* gnu/machine.scm (&deploy-error): Remove.
* gnu/machine/ssh.scm (with-roll-back): Remove.
(deploy-managed-host): Remove with-roll-back.
* guix/scripts/deploy.scm (deploy-machine*): Remove deploy-error? case.

Change-Id: I719eafda0f5d12e1f4e3795631e78378f5376745
---
 gnu/machine.scm         | 17 +-------------
 gnu/machine/ssh.scm     | 51 +++++++++++++++--------------------------
 guix/scripts/deploy.scm |  8 +------
 3 files changed, 20 insertions(+), 56 deletions(-)

diff --git a/gnu/machine.scm b/gnu/machine.scm
index 60be674972..ede595d053 100644
--- a/gnu/machine.scm
+++ b/gnu/machine.scm
@@ -41,12 +41,7 @@ (define-module (gnu machine)
 
             deploy-machine
             roll-back-machine
-            machine-remote-eval
-
-            &deploy-error
-            deploy-error?
-            deploy-error-should-roll-back
-            deploy-error-captured-args))
+            machine-remote-eval))
 
 ;;; Commentary:
 ;;;
@@ -122,13 +117,3 @@ (define (roll-back-machine machine)
 and the new generation number."
   (let ((environment (machine-environment machine)))
     ((environment-type-roll-back-machine environment) machine)))
-
-\f
-;;;
-;;; Error types.
-;;;
-
-(define-condition-type &deploy-error &error
-  deploy-error?
-  (should-roll-back deploy-error-should-roll-back)
-  (captured-args deploy-error-captured-args))
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 3e69d4b9a3..b954620b69 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -480,18 +480,6 @@ (define (machine-boot-parameters machine)
                            (boot-parameters-kernel-arguments params))))))))
           remote-results))))
 
-(define-syntax-rule (with-roll-back should-roll-back? mbody ...)
-  "Catch exceptions that arise when binding MBODY, a monadic expression in
-%STORE-MONAD, and collect their arguments in a &deploy-error condition, with
-the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
-  (catch #t
-    (lambda ()
-      mbody ...)
-    (lambda args
-      (raise (condition (&deploy-error
-                         (should-roll-back should-roll-back?)
-                         (captured-args args)))))))
-
 (define (deploy-managed-host machine)
   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 environment type of 'managed-host."
@@ -536,32 +524,29 @@ (define (deploy-managed-host machine)
                         store)))))
 
         (mbegin %store-monad
-          (with-roll-back #f
-            (switch-to-system (eval/error-handling c
-                                (raise (formatted-message
-                                        (G_ "\
+          (switch-to-system (eval/error-handling c
+                              (raise (formatted-message
+                                      (G_ "\
 failed to switch systems while deploying '~a':~%~{~s ~}")
-                                        host
-                                        (inferior-exception-arguments c))))
-                              os))
+                                      host
+                                      (inferior-exception-arguments c))))
+                            os)
           (parameterize ((%current-system system)
                          (%current-target-system #f))
-            (with-roll-back #t
-              (mbegin %store-monad
-                (upgrade-shepherd-services (eval/error-handling c
-                                             (warning (G_ "\
+            (mbegin %store-monad
+              (upgrade-shepherd-services
+                (eval/error-handling c
+                  (warning (G_ "\
 an error occurred while upgrading services on '~a':~%~{~s ~}~%")
-                                                      host
-                                                      (inferior-exception-arguments
-                                                       c)))
-                                           os)
-                (install-bootloader (eval/error-handling c
-                                      (raise (formatted-message
-                                              (G_ "\
+                           host (inferior-exception-arguments c)))
+                os)
+              (install-bootloader
+                (eval/error-handling c
+                  (raise (formatted-message
+                           (G_ "\
 failed to install bootloader on '~a':~%~{~s ~}~%")
-                                              host
-                                              (inferior-exception-arguments c))))
-                                    bootloader-configuration bootcfg)))))))))
+                           host (inferior-exception-arguments c))))
+                bootloader-configuration bootcfg))))))))
 
 \f
 ;;;
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 4b1a603049..ca0e1c4023 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -156,13 +156,7 @@ (define (deploy-machine* store machine)
                    (apply format #f
                           (gettext (formatted-message-string c)
                                    %gettext-domain)
-                          (formatted-message-arguments 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))))
+                          (formatted-message-arguments c)))))
       (run-with-store store (deploy-machine machine))
 
     (info (G_ "successfully deployed ~a~%")
-- 
2.45.2