[bug#75010,v4,3/5] gnu: machine: Remove &deploy-error.
Commit Message
* 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(-)
@@ -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))
@@ -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))))))))
;;;
@@ -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~%")