GNU bug report logs - #75010
[PATCH 0/7] Roll back when deployment fails.

Previous Next

Full log

Message #73 received at 75010 <at> debbugs.gnu.org (full text, mbox):

From: Herman Rimm <herman <at> rimm.ee>
To: 75010 <at> debbugs.gnu.org
Subject: [PATCH v4 3/5] gnu: machine: Remove &deploy-error.
Date: Fri,  9 May 2025 08:02:27 +0200

* 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     | 62 +++++++++++++++--------------------------
 guix/scripts/deploy.scm |  8 +-----
 3 files changed, 25 insertions(+), 62 deletions(-)

diff --git a/gnu/machine.scm b/gnu/machine.scm
index 60be6749727..ede595d053d 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)))
-
-
-;;;
-;;; 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 47f379c57e3..aea390fe0b3 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -481,18 +481,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."
@@ -537,39 +525,35 @@ (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)
-                (load-system-for-kexec (eval/error-handling c
-                                         (warning (G_ "\
+                           host (inferior-exception-arguments c)))
+                os)
+              (load-system-for-kexec
+                (eval/error-handling c
+                  (warning (G_ "\
 failed to load system of '~a' for kexec reboot:~%~{~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))))))))
 
 
 ;;;
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index e2ef0006e06..f80982b6d18 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -181,13 +181,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.48.1

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.