[PATCH] machine: Implement 'roll-back-machine'.

  • Done
  • quality assurance status badge
Details
3 participants
  • Christopher Lemmer Webber
  • Ricardo Wurmus
  • Jakob L. Kreuze
Owner
unassigned
Submitted by
Jakob L. Kreuze
Severity
normal

Debbugs page

Jakob L. Kreuze wrote 6 years ago
(address . guix-patches@gnu.org)
87v9v94067.fsf@sdf.lonestar.org
* gnu/machine.scm (roll-back-machine, &deploy-error, deploy-error?)
(deploy-error-should-roll-back)
(deploy-error-captured-args): New variable.
* gnu/machine/ssh.scm (roll-back-managed-host): New variable.
* guix/scripts/deploy.scm (guix-deploy): Roll-back systems when a
deployment fails.
---
gnu/machine.scm | 27 ++++++++++++++-
gnu/machine/ssh.scm | 75 +++++++++++++++++++++++++++++++++++++++--
guix/remote.scm | 1 +
guix/scripts/deploy.scm | 17 ++++++++--
4 files changed, 114 insertions(+), 6 deletions(-)

Toggle diff (220 lines)
diff --git a/gnu/machine.scm b/gnu/machine.scm
index 30ae97f6ec..05b03b21d4 100644
--- a/gnu/machine.scm
+++ b/gnu/machine.scm
@@ -24,6 +24,7 @@
#:use-module (guix records)
#:use-module (guix store)
#:use-module ((guix utils) #:select (source-properties->location))
+ #:use-module (srfi srfi-35)
#:export (environment-type
environment-type?
environment-type-name
@@ -40,7 +41,13 @@
machine-display-name
deploy-machine
- machine-remote-eval))
+ roll-back-machine
+ machine-remote-eval
+
+ &deploy-error
+ deploy-error?
+ deploy-error-should-roll-back
+ deploy-error-captured-args))
;;; Commentary:
;;;
@@ -66,6 +73,7 @@
;; of the form '(machine-remote-eval machine exp)'.
(machine-remote-eval environment-type-machine-remote-eval) ; procedure
(deploy-machine environment-type-deploy-machine) ; procedure
+ (roll-back-machine environment-type-roll-back-machine) ; procedure
;; Metadata.
(name environment-type-name) ; symbol
@@ -105,3 +113,20 @@ are built and deployed to MACHINE beforehand."
MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
(let ((environment (machine-environment machine)))
((environment-type-deploy-machine environment) machine)))
+
+(define (roll-back-machine machine)
+ "Monadic procedure rolling back to the previous system generation on
+MACHINE. Return the number of the generation that was current before switching
+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 274d56db26..ae312597dd 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu machine ssh)
+ #:use-module (gnu bootloader)
#:use-module (gnu machine)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu system)
@@ -34,8 +35,10 @@
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (managed-host-environment-type
@@ -304,6 +307,18 @@ of MACHINE's system profile, ordered from most recent to oldest."
(boot-parameters-kernel-arguments params))))))))
generations))))
+(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."
@@ -316,9 +331,62 @@ environment type of 'managed-host."
(bootloader-configuration (operating-system-bootloader os))
(bootcfg (operating-system-bootcfg os menu-entries)))
(mbegin %store-monad
- (switch-to-system eval os)
- (upgrade-shepherd-services eval os)
- (install-bootloader eval bootloader-configuration bootcfg)))))
+ (with-roll-back #f
+ (switch-to-system eval os))
+ (with-roll-back #t
+ (mbegin %store-monad
+ (upgrade-shepherd-services eval os)
+ (install-bootloader eval bootloader-configuration bootcfg)))))))
+
+
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-managed-host machine)
+ "Internal implementation of 'roll-back-machine' for MACHINE instances with
+an environment type of 'managed-host."
+ (define remote-exp
+ (with-extensions (list guile-gcrypt)
+ (with-imported-modules (source-module-closure '((guix config)
+ (guix profiles)))
+ #~(begin
+ (use-modules (guix config)
+ (guix profiles))
+
+ (define %system-profile
+ (string-append %state-directory "/profiles/system"))
+
+ (define target-generation
+ (relative-generation-spec->number %system-profile "-1"))
+
+ (if target-generation
+ (switch-to-generation %system-profile target-generation)
+ 'error)))))
+
+ (define roll-back-failure
+ (condition (&message (message (G_ "could not roll-back machine")))))
+
+ (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
+ (_ -> (if (< (length boot-parameters) 2)
+ (raise roll-back-failure)))
+ (entries -> (map boot-parameters->menu-entry
+ (list (second boot-parameters))))
+ (old-entries -> (map boot-parameters->menu-entry
+ (drop boot-parameters 2)))
+ (bootloader -> (operating-system-bootloader
+ (machine-operating-system machine)))
+ (bootcfg (lower-object
+ ((bootloader-configuration-file-generator
+ (bootloader-configuration-bootloader
+ bootloader))
+ bootloader entries
+ #:old-entries old-entries)))
+ (eval -> (cut machine-remote-eval machine <>))
+ (remote-result (machine-remote-eval machine
+ remote-exp)))
+ (when (eqv? 'error remote-result)
+ (raise roll-back-failure))))
;;;
@@ -329,6 +397,7 @@ environment type of 'managed-host."
(environment-type
(machine-remote-eval managed-host-remote-eval)
(deploy-machine deploy-managed-host)
+ (roll-back-machine roll-back-managed-host)
(name 'managed-host-environment-type)
(description "Provisioning for machines that are accessible over SSH
and have a known host-name. This entails little more than maintaining an SSH
diff --git a/guix/remote.scm b/guix/remote.scm
index 0a0bdaf30b..d5738ebbfa 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -24,6 +24,7 @@
#:use-module (guix monads)
#:use-module (guix modules)
#:use-module (guix derivations)
+ #:use-module (guix utils)
#:use-module (ssh popen)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 52d5e1e1da..bc1d93a93a 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -27,6 +27,8 @@
#:use-module (guix grafts)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:export (guix-deploy))
@@ -84,7 +86,18 @@ Perform the deployment specified by FILE.\n"))
(with-store store
(set-build-options-from-command-line store opts)
(for-each (lambda (machine)
- (info (G_ "deploying to ~a...") (machine-display-name machine))
+ (info (G_ "deploying to ~a...~%")
+ (machine-display-name machine))
(parameterize ((%graft? (assq-ref opts 'graft?)))
- (run-with-store store (deploy-machine 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)))))
machines))))
--
2.22.0
-----BEGIN PGP SIGNATURE-----

iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl1KxyEACgkQ9Qb9Fp2P
2Vr6mg/+Pnus0ohWQoPsGNYvabPZodH+d6fuSaVYI3iwdzYRGv9LJKiXJYxukvvK
dsoZajyQ4FltLN9TJHHEPR/grbcXPvl2idLZHRRRUKG9LKum11pzzUyy0lzUYWo1
K3sbND0ACOu5xjT7PMguwB7JFcysaQ7dXF4EUi9jM0FG6xGL2bdip9zRByykzKfw
KoJBKMfETRuzDwBT1t9dUGZeEeSWyzUOh2sEEBXfQ6ufSy7+4Le8c9e62Gy/wakT
9lFN6iNfociA/zh1gN37eyZZra3nnocvDgmuDUqu9YeGxPoq+ExXH6n2n7asjKls
N04DuCeEWT4ed0KzZWUATAV2OZ2jUTQ9QgqDbIzfT/sp54LcsfaCEQaGpX2EVRbp
v/j+MpZi8UxFgNUvUHcDuOZ2vcEA9Xk8kemrKirjLAuonzLHI/Zj9ButnnkZWtRt
pWUmVznqBXaxIMqcAeNDpi66q8ewm3D2RsS9JN20QBzdNKxJEfKVmgCRcltRofRY
vgkDtsKGNqOZlI1PzEVcW1YdoWapSrZUU08G777rsMa9s3flRT8G61GMz5hd5FUt
dmqcQMbzXrMEpohwPShDSysk17tLHzYC6R9bO0uhVIIaxFI6rab9cczAwc3h9Im2
UZfIo3VaQcIhPgMQj0K9YTlWmlB2ns2p1xYYC1OkV+IPDdl/TIk=
=cZ2t
-----END PGP SIGNATURE-----

Christopher Lemmer Webber wrote 6 years ago
(address . guix-patches@gnu.org)(address . 36952@debbugs.gnu.org)
87v9v8ohvq.fsf@dustycloud.org
I don't notice any obvious bugs, but I'm not fully confident in my
ability to catch them here. Another set of eyes might help.

This doesn't apply on top of current master though; could you rebase?

Jakob L. Kreuze writes:

Toggle quote (231 lines)
> * gnu/machine.scm (roll-back-machine, &deploy-error, deploy-error?)
> (deploy-error-should-roll-back)
> (deploy-error-captured-args): New variable.
> * gnu/machine/ssh.scm (roll-back-managed-host): New variable.
> * guix/scripts/deploy.scm (guix-deploy): Roll-back systems when a
> deployment fails.
> ---
> gnu/machine.scm | 27 ++++++++++++++-
> gnu/machine/ssh.scm | 75 +++++++++++++++++++++++++++++++++++++++--
> guix/remote.scm | 1 +
> guix/scripts/deploy.scm | 17 ++++++++--
> 4 files changed, 114 insertions(+), 6 deletions(-)
>
> diff --git a/gnu/machine.scm b/gnu/machine.scm
> index 30ae97f6ec..05b03b21d4 100644
> --- a/gnu/machine.scm
> +++ b/gnu/machine.scm
> @@ -24,6 +24,7 @@
> #:use-module (guix records)
> #:use-module (guix store)
> #:use-module ((guix utils) #:select (source-properties->location))
> + #:use-module (srfi srfi-35)
> #:export (environment-type
> environment-type?
> environment-type-name
> @@ -40,7 +41,13 @@
> machine-display-name
>
> deploy-machine
> - machine-remote-eval))
> + roll-back-machine
> + machine-remote-eval
> +
> + &deploy-error
> + deploy-error?
> + deploy-error-should-roll-back
> + deploy-error-captured-args))
>
> ;;; Commentary:
> ;;;
> @@ -66,6 +73,7 @@
> ;; of the form '(machine-remote-eval machine exp)'.
> (machine-remote-eval environment-type-machine-remote-eval) ; procedure
> (deploy-machine environment-type-deploy-machine) ; procedure
> + (roll-back-machine environment-type-roll-back-machine) ; procedure
>
> ;; Metadata.
> (name environment-type-name) ; symbol
> @@ -105,3 +113,20 @@ are built and deployed to MACHINE beforehand."
> MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
> (let ((environment (machine-environment machine)))
> ((environment-type-deploy-machine environment) machine)))
> +
> +(define (roll-back-machine machine)
> + "Monadic procedure rolling back to the previous system generation on
> +MACHINE. Return the number of the generation that was current before switching
> +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 274d56db26..ae312597dd 100644
> --- a/gnu/machine/ssh.scm
> +++ b/gnu/machine/ssh.scm
> @@ -17,6 +17,7 @@
> ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
>
> (define-module (gnu machine ssh)
> + #:use-module (gnu bootloader)
> #:use-module (gnu machine)
> #:autoload (gnu packages gnupg) (guile-gcrypt)
> #:use-module (gnu system)
> @@ -34,8 +35,10 @@
> #:use-module (guix store)
> #:use-module (guix utils)
> #:use-module (ice-9 match)
> + #:use-module (srfi srfi-1)
> #:use-module (srfi srfi-19)
> #:use-module (srfi srfi-26)
> + #:use-module (srfi srfi-34)
> #:use-module (srfi srfi-35)
> #:export (managed-host-environment-type
>
> @@ -304,6 +307,18 @@ of MACHINE's system profile, ordered from most recent to oldest."
> (boot-parameters-kernel-arguments params))))))))
> generations))))
>
> +(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."
> @@ -316,9 +331,62 @@ environment type of 'managed-host."
> (bootloader-configuration (operating-system-bootloader os))
> (bootcfg (operating-system-bootcfg os menu-entries)))
> (mbegin %store-monad
> - (switch-to-system eval os)
> - (upgrade-shepherd-services eval os)
> - (install-bootloader eval bootloader-configuration bootcfg)))))
> + (with-roll-back #f
> + (switch-to-system eval os))
> + (with-roll-back #t
> + (mbegin %store-monad
> + (upgrade-shepherd-services eval os)
> + (install-bootloader eval bootloader-configuration bootcfg)))))))
> +
> +
> +;;;
> +;;; Roll-back.
> +;;;
> +
> +(define (roll-back-managed-host machine)
> + "Internal implementation of 'roll-back-machine' for MACHINE instances with
> +an environment type of 'managed-host."
> + (define remote-exp
> + (with-extensions (list guile-gcrypt)
> + (with-imported-modules (source-module-closure '((guix config)
> + (guix profiles)))
> + #~(begin
> + (use-modules (guix config)
> + (guix profiles))
> +
> + (define %system-profile
> + (string-append %state-directory "/profiles/system"))
> +
> + (define target-generation
> + (relative-generation-spec->number %system-profile "-1"))
> +
> + (if target-generation
> + (switch-to-generation %system-profile target-generation)
> + 'error)))))
> +
> + (define roll-back-failure
> + (condition (&message (message (G_ "could not roll-back machine")))))
> +
> + (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
> + (_ -> (if (< (length boot-parameters) 2)
> + (raise roll-back-failure)))
> + (entries -> (map boot-parameters->menu-entry
> + (list (second boot-parameters))))
> + (old-entries -> (map boot-parameters->menu-entry
> + (drop boot-parameters 2)))
> + (bootloader -> (operating-system-bootloader
> + (machine-operating-system machine)))
> + (bootcfg (lower-object
> + ((bootloader-configuration-file-generator
> + (bootloader-configuration-bootloader
> + bootloader))
> + bootloader entries
> + #:old-entries old-entries)))
> + (eval -> (cut machine-remote-eval machine <>))
> + (remote-result (machine-remote-eval machine
> + remote-exp)))
> + (when (eqv? 'error remote-result)
> + (raise roll-back-failure))))
>
>
> ;;;
> @@ -329,6 +397,7 @@ environment type of 'managed-host."
> (environment-type
> (machine-remote-eval managed-host-remote-eval)
> (deploy-machine deploy-managed-host)
> + (roll-back-machine roll-back-managed-host)
> (name 'managed-host-environment-type)
> (description "Provisioning for machines that are accessible over SSH
> and have a known host-name. This entails little more than maintaining an SSH
> diff --git a/guix/remote.scm b/guix/remote.scm
> index 0a0bdaf30b..d5738ebbfa 100644
> --- a/guix/remote.scm
> +++ b/guix/remote.scm
> @@ -24,6 +24,7 @@
> #:use-module (guix monads)
> #:use-module (guix modules)
> #:use-module (guix derivations)
> + #:use-module (guix utils)
> #:use-module (ssh popen)
> #:use-module (srfi srfi-1)
> #:use-module (ice-9 match)
> diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
> index 52d5e1e1da..bc1d93a93a 100644
> --- a/guix/scripts/deploy.scm
> +++ b/guix/scripts/deploy.scm
> @@ -27,6 +27,8 @@
> #:use-module (guix grafts)
> #:use-module (ice-9 format)
> #:use-module (srfi srfi-1)
> + #:use-module (srfi srfi-34)
> + #:use-module (srfi srfi-35)
> #:use-module (srfi srfi-37)
> #:export (guix-deploy))
>
> @@ -84,7 +86,18 @@ Perform the deployment specified by FILE.\n"))
> (with-store store
> (set-build-options-from-command-line store opts)
> (for-each (lambda (machine)
> - (info (G_ "deploying to ~a...") (machine-display-name machine))
> + (info (G_ "deploying to ~a...~%")
> + (machine-display-name machine))
> (parameterize ((%graft? (assq-ref opts 'graft?)))
> - (run-with-store store (deploy-machine 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)))))
> machines))))
Jakob L. Kreuze wrote 6 years ago
Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'.
(name . Christopher Lemmer Webber)(address . cwebber@dustycloud.org)(address . 36952@debbugs.gnu.org)
87v9v8k82l.fsf_-_@sdf.lonestar.org
* gnu/machine.scm (roll-back-machine, &deploy-error, deploy-error?)
(deploy-error-should-roll-back)
(deploy-error-captured-args): New variable.
* gnu/machine/ssh.scm (roll-back-managed-host): New variable.
* guix/scripts/deploy.scm (guix-deploy): Roll-back systems when a
deployment fails.
---
gnu/machine.scm | 27 ++++++++++++++-
gnu/machine/ssh.scm | 75 +++++++++++++++++++++++++++++++++++++++--
guix/remote.scm | 1 +
guix/scripts/deploy.scm | 17 ++++++++--
4 files changed, 114 insertions(+), 6 deletions(-)

Toggle diff (221 lines)
diff --git a/gnu/machine.scm b/gnu/machine.scm
index 30ae97f6ec..05b03b21d4 100644
--- a/gnu/machine.scm
+++ b/gnu/machine.scm
@@ -24,6 +24,7 @@
#:use-module (guix records)
#:use-module (guix store)
#:use-module ((guix utils) #:select (source-properties->location))
+ #:use-module (srfi srfi-35)
#:export (environment-type
environment-type?
environment-type-name
@@ -40,7 +41,13 @@
machine-display-name
deploy-machine
- machine-remote-eval))
+ roll-back-machine
+ machine-remote-eval
+
+ &deploy-error
+ deploy-error?
+ deploy-error-should-roll-back
+ deploy-error-captured-args))
;;; Commentary:
;;;
@@ -66,6 +73,7 @@
;; of the form '(machine-remote-eval machine exp)'.
(machine-remote-eval environment-type-machine-remote-eval) ; procedure
(deploy-machine environment-type-deploy-machine) ; procedure
+ (roll-back-machine environment-type-roll-back-machine) ; procedure
;; Metadata.
(name environment-type-name) ; symbol
@@ -105,3 +113,20 @@ are built and deployed to MACHINE beforehand."
MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
(let ((environment (machine-environment machine)))
((environment-type-deploy-machine environment) machine)))
+
+(define (roll-back-machine machine)
+ "Monadic procedure rolling back to the previous system generation on
+MACHINE. Return the number of the generation that was current before switching
+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 274d56db26..ae312597dd 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu machine ssh)
+ #:use-module (gnu bootloader)
#:use-module (gnu machine)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu system)
@@ -34,8 +35,10 @@
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (managed-host-environment-type
@@ -304,6 +307,18 @@ of MACHINE's system profile, ordered from most recent to oldest."
(boot-parameters-kernel-arguments params))))))))
generations))))
+(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."
@@ -316,9 +331,62 @@ environment type of 'managed-host."
(bootloader-configuration (operating-system-bootloader os))
(bootcfg (operating-system-bootcfg os menu-entries)))
(mbegin %store-monad
- (switch-to-system eval os)
- (upgrade-shepherd-services eval os)
- (install-bootloader eval bootloader-configuration bootcfg)))))
+ (with-roll-back #f
+ (switch-to-system eval os))
+ (with-roll-back #t
+ (mbegin %store-monad
+ (upgrade-shepherd-services eval os)
+ (install-bootloader eval bootloader-configuration bootcfg)))))))
+
+
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-managed-host machine)
+ "Internal implementation of 'roll-back-machine' for MACHINE instances with
+an environment type of 'managed-host."
+ (define remote-exp
+ (with-extensions (list guile-gcrypt)
+ (with-imported-modules (source-module-closure '((guix config)
+ (guix profiles)))
+ #~(begin
+ (use-modules (guix config)
+ (guix profiles))
+
+ (define %system-profile
+ (string-append %state-directory "/profiles/system"))
+
+ (define target-generation
+ (relative-generation-spec->number %system-profile "-1"))
+
+ (if target-generation
+ (switch-to-generation %system-profile target-generation)
+ 'error)))))
+
+ (define roll-back-failure
+ (condition (&message (message (G_ "could not roll-back machine")))))
+
+ (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
+ (_ -> (if (< (length boot-parameters) 2)
+ (raise roll-back-failure)))
+ (entries -> (map boot-parameters->menu-entry
+ (list (second boot-parameters))))
+ (old-entries -> (map boot-parameters->menu-entry
+ (drop boot-parameters 2)))
+ (bootloader -> (operating-system-bootloader
+ (machine-operating-system machine)))
+ (bootcfg (lower-object
+ ((bootloader-configuration-file-generator
+ (bootloader-configuration-bootloader
+ bootloader))
+ bootloader entries
+ #:old-entries old-entries)))
+ (eval -> (cut machine-remote-eval machine <>))
+ (remote-result (machine-remote-eval machine
+ remote-exp)))
+ (when (eqv? 'error remote-result)
+ (raise roll-back-failure))))
;;;
@@ -329,6 +397,7 @@ environment type of 'managed-host."
(environment-type
(machine-remote-eval managed-host-remote-eval)
(deploy-machine deploy-managed-host)
+ (roll-back-machine roll-back-managed-host)
(name 'managed-host-environment-type)
(description "Provisioning for machines that are accessible over SSH
and have a known host-name. This entails little more than maintaining an SSH
diff --git a/guix/remote.scm b/guix/remote.scm
index 5fecd954e9..853029c54f 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -24,6 +24,7 @@
#:use-module (guix monads)
#:use-module (guix modules)
#:use-module (guix derivations)
+ #:use-module (guix utils)
#:use-module (ssh popen)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index ebc99e52cc..d16e7d7480 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -28,6 +28,8 @@
#:use-module (guix grafts)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:export (guix-deploy))
@@ -91,8 +93,19 @@ Perform the deployment specified by FILE.\n"))
(with-store store
(set-build-options-from-command-line store opts)
(for-each (lambda (machine)
- (info (G_ "deploying to ~a...") (machine-display-name machine))
+ (info (G_ "deploying to ~a...~%")
+ (machine-display-name machine))
(parameterize ((%current-system (assq-ref opts 'system))
(%graft? (assq-ref opts 'graft?)))
- (run-with-store store (deploy-machine 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)))))
machines))))
--
2.22.0
-----BEGIN PGP SIGNATURE-----

iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl1LOyIACgkQ9Qb9Fp2P
2VoCvxAAppGfVYme2uuGk/NXKZP7h3ReraQACGxWwCHrg5oCI8azsR2hAO3+SbHG
bvC96HLWy+87jh5TMmbjwr/QuJIrqwJ2zvX/54CyzCSUFaTVoJ66mqZiKGVUZt28
jehnD+TOUC8jp80ilobZm3PXXqeolQKb//AklEp/yaC6NxeLMtjceotl32w0jTEn
iD9SiJGjgxcbnt8jue+hE5PpEy8f3PkCYcte0oHIutRl7T1AcuSx9xQOJso+MZ0Q
igdZDRpYX8tsOLYhDxnVkWmWJhBVpXRxLFTo1JNSOrDOUc+sxZrH4PyfjN47iSfi
+2Jl989AwLJxsV5ONBiVtKL7jWjkZBdTxHI3T0Ir6nVPyJJF704acKcLAnWkEj34
+vP0vLWYL7VpMLHdQkEdOxJKJBKBeu25181HdStPOvL7+MbdpYlp8sY39IRlhJ9e
AdqyQ6YtzWC+1rRllYzM2j9rRwZhpqkjAicZe4q79ItgzpbKsKTCdN9L7LJXcdXp
c6WwDKDmJEVzrij+cXizypzBEfD9+WYSobo04Q/B5bjMwe32HXgwvlBlm+kVyj0V
ToirMKShNMQKZFRlAA92N913XpxGvCjmL02tDaQCzPEzCdRl0HS+jRe2xTvS7tC6
tjQxpCGBjvU419S6rWdeUG73zwcDTxbMWgEjsgsfLFMoUPo49x4=
=68+q
-----END PGP SIGNATURE-----

Christopher Lemmer Webber wrote 6 years ago
(address . 36952@debbugs.gnu.org)
87r25wobbh.fsf@dustycloud.org
Thanks. I'm going to specifically loop in Dave...

Dave, mind peering over this before I merge it?

Jakob L. Kreuze writes:

Toggle quote (232 lines)
> * gnu/machine.scm (roll-back-machine, &deploy-error, deploy-error?)
> (deploy-error-should-roll-back)
> (deploy-error-captured-args): New variable.
> * gnu/machine/ssh.scm (roll-back-managed-host): New variable.
> * guix/scripts/deploy.scm (guix-deploy): Roll-back systems when a
> deployment fails.
> ---
> gnu/machine.scm | 27 ++++++++++++++-
> gnu/machine/ssh.scm | 75 +++++++++++++++++++++++++++++++++++++++--
> guix/remote.scm | 1 +
> guix/scripts/deploy.scm | 17 ++++++++--
> 4 files changed, 114 insertions(+), 6 deletions(-)
>
> diff --git a/gnu/machine.scm b/gnu/machine.scm
> index 30ae97f6ec..05b03b21d4 100644
> --- a/gnu/machine.scm
> +++ b/gnu/machine.scm
> @@ -24,6 +24,7 @@
> #:use-module (guix records)
> #:use-module (guix store)
> #:use-module ((guix utils) #:select (source-properties->location))
> + #:use-module (srfi srfi-35)
> #:export (environment-type
> environment-type?
> environment-type-name
> @@ -40,7 +41,13 @@
> machine-display-name
>
> deploy-machine
> - machine-remote-eval))
> + roll-back-machine
> + machine-remote-eval
> +
> + &deploy-error
> + deploy-error?
> + deploy-error-should-roll-back
> + deploy-error-captured-args))
>
> ;;; Commentary:
> ;;;
> @@ -66,6 +73,7 @@
> ;; of the form '(machine-remote-eval machine exp)'.
> (machine-remote-eval environment-type-machine-remote-eval) ; procedure
> (deploy-machine environment-type-deploy-machine) ; procedure
> + (roll-back-machine environment-type-roll-back-machine) ; procedure
>
> ;; Metadata.
> (name environment-type-name) ; symbol
> @@ -105,3 +113,20 @@ are built and deployed to MACHINE beforehand."
> MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
> (let ((environment (machine-environment machine)))
> ((environment-type-deploy-machine environment) machine)))
> +
> +(define (roll-back-machine machine)
> + "Monadic procedure rolling back to the previous system generation on
> +MACHINE. Return the number of the generation that was current before switching
> +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 274d56db26..ae312597dd 100644
> --- a/gnu/machine/ssh.scm
> +++ b/gnu/machine/ssh.scm
> @@ -17,6 +17,7 @@
> ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
>
> (define-module (gnu machine ssh)
> + #:use-module (gnu bootloader)
> #:use-module (gnu machine)
> #:autoload (gnu packages gnupg) (guile-gcrypt)
> #:use-module (gnu system)
> @@ -34,8 +35,10 @@
> #:use-module (guix store)
> #:use-module (guix utils)
> #:use-module (ice-9 match)
> + #:use-module (srfi srfi-1)
> #:use-module (srfi srfi-19)
> #:use-module (srfi srfi-26)
> + #:use-module (srfi srfi-34)
> #:use-module (srfi srfi-35)
> #:export (managed-host-environment-type
>
> @@ -304,6 +307,18 @@ of MACHINE's system profile, ordered from most recent to oldest."
> (boot-parameters-kernel-arguments params))))))))
> generations))))
>
> +(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."
> @@ -316,9 +331,62 @@ environment type of 'managed-host."
> (bootloader-configuration (operating-system-bootloader os))
> (bootcfg (operating-system-bootcfg os menu-entries)))
> (mbegin %store-monad
> - (switch-to-system eval os)
> - (upgrade-shepherd-services eval os)
> - (install-bootloader eval bootloader-configuration bootcfg)))))
> + (with-roll-back #f
> + (switch-to-system eval os))
> + (with-roll-back #t
> + (mbegin %store-monad
> + (upgrade-shepherd-services eval os)
> + (install-bootloader eval bootloader-configuration bootcfg)))))))
> +
> +
> +;;;
> +;;; Roll-back.
> +;;;
> +
> +(define (roll-back-managed-host machine)
> + "Internal implementation of 'roll-back-machine' for MACHINE instances with
> +an environment type of 'managed-host."
> + (define remote-exp
> + (with-extensions (list guile-gcrypt)
> + (with-imported-modules (source-module-closure '((guix config)
> + (guix profiles)))
> + #~(begin
> + (use-modules (guix config)
> + (guix profiles))
> +
> + (define %system-profile
> + (string-append %state-directory "/profiles/system"))
> +
> + (define target-generation
> + (relative-generation-spec->number %system-profile "-1"))
> +
> + (if target-generation
> + (switch-to-generation %system-profile target-generation)
> + 'error)))))
> +
> + (define roll-back-failure
> + (condition (&message (message (G_ "could not roll-back machine")))))
> +
> + (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
> + (_ -> (if (< (length boot-parameters) 2)
> + (raise roll-back-failure)))
> + (entries -> (map boot-parameters->menu-entry
> + (list (second boot-parameters))))
> + (old-entries -> (map boot-parameters->menu-entry
> + (drop boot-parameters 2)))
> + (bootloader -> (operating-system-bootloader
> + (machine-operating-system machine)))
> + (bootcfg (lower-object
> + ((bootloader-configuration-file-generator
> + (bootloader-configuration-bootloader
> + bootloader))
> + bootloader entries
> + #:old-entries old-entries)))
> + (eval -> (cut machine-remote-eval machine <>))
> + (remote-result (machine-remote-eval machine
> + remote-exp)))
> + (when (eqv? 'error remote-result)
> + (raise roll-back-failure))))
>
>
> ;;;
> @@ -329,6 +397,7 @@ environment type of 'managed-host."
> (environment-type
> (machine-remote-eval managed-host-remote-eval)
> (deploy-machine deploy-managed-host)
> + (roll-back-machine roll-back-managed-host)
> (name 'managed-host-environment-type)
> (description "Provisioning for machines that are accessible over SSH
> and have a known host-name. This entails little more than maintaining an SSH
> diff --git a/guix/remote.scm b/guix/remote.scm
> index 5fecd954e9..853029c54f 100644
> --- a/guix/remote.scm
> +++ b/guix/remote.scm
> @@ -24,6 +24,7 @@
> #:use-module (guix monads)
> #:use-module (guix modules)
> #:use-module (guix derivations)
> + #:use-module (guix utils)
> #:use-module (ssh popen)
> #:use-module (srfi srfi-1)
> #:use-module (ice-9 match)
> diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
> index ebc99e52cc..d16e7d7480 100644
> --- a/guix/scripts/deploy.scm
> +++ b/guix/scripts/deploy.scm
> @@ -28,6 +28,8 @@
> #:use-module (guix grafts)
> #:use-module (ice-9 format)
> #:use-module (srfi srfi-1)
> + #:use-module (srfi srfi-34)
> + #:use-module (srfi srfi-35)
> #:use-module (srfi srfi-37)
> #:export (guix-deploy))
>
> @@ -91,8 +93,19 @@ Perform the deployment specified by FILE.\n"))
> (with-store store
> (set-build-options-from-command-line store opts)
> (for-each (lambda (machine)
> - (info (G_ "deploying to ~a...") (machine-display-name machine))
> + (info (G_ "deploying to ~a...~%")
> + (machine-display-name machine))
> (parameterize ((%current-system (assq-ref opts 'system))
> (%graft? (assq-ref opts 'graft?)))
> - (run-with-store store (deploy-machine 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)))))
> machines))))
Ricardo Wurmus wrote 6 years ago
(name . Jakob L. Kreuze)(address . zerodaysfordays@sdf.lonestar.org)
87v9v8vskt.fsf@elephly.net
Hi Jakob,

Toggle quote (17 lines)
> +(define (roll-back-managed-host machine)
> + "Internal implementation of 'roll-back-machine' for MACHINE instances with
> +an environment type of 'managed-host."
> + (define remote-exp
> + (with-extensions (list guile-gcrypt)
> + (with-imported-modules (source-module-closure '((guix config)
> + (guix profiles)))
> + #~(begin
> + (use-modules (guix config)
> + (guix profiles))
> +
> + (define %system-profile
> + (string-append %state-directory "/profiles/system"))
> +
> + (define target-generation
> + (relative-generation-spec->number %system-profile "-1"))

Can we use “relative-generation” or “previous-generation-number” here?
I think the stringified “-1” is kinda ugly, and the “*-spec” procedure
only exists to handle user input, which is provided as a string.

Toggle quote (20 lines)
> + (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
> + (_ -> (if (< (length boot-parameters) 2)
> + (raise roll-back-failure)))
> + (entries -> (map boot-parameters->menu-entry
> + (list (second boot-parameters))))
> + (old-entries -> (map boot-parameters->menu-entry
> + (drop boot-parameters 2)))
> + (bootloader -> (operating-system-bootloader
> + (machine-operating-system machine)))
> + (bootcfg (lower-object
> + ((bootloader-configuration-file-generator
> + (bootloader-configuration-bootloader
> + bootloader))
> + bootloader entries
> + #:old-entries old-entries)))
> + (eval -> (cut machine-remote-eval machine <>))
> + (remote-result (machine-remote-eval machine
> +
> remote-exp)))

Is it on purpose that you aren’t using the previously defined “eval”
here?

--
Ricardo
Jakob L. Kreuze wrote 6 years ago
(name . Ricardo Wurmus)(address . rekado@elephly.net)
8736ibl8f0.fsf@sdf.lonestar.org
Hi Ricardo,

Ricardo Wurmus <rekado@elephly.net> writes:

Toggle quote (4 lines)
> Can we use “relative-generation” or “previous-generation-number” here?
> I think the stringified “-1” is kinda ugly, and the “*-spec” procedure
> only exists to handle user input, which is provided as a string.

Oh yeah, definitely. I used '*-spec' here because I was using 'guix
system' as a model -- didn't know it was meant for handling user input.

Toggle quote (3 lines)
> Is it on purpose that you aren’t using the previously defined “eval”
> here?

Whoops! Unused variable, nice catch!

Thanks for the review!

Regards,
Jakob
-----BEGIN PGP SIGNATURE-----

iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl1MgyYACgkQ9Qb9Fp2P
2VoWXQ/8CJlZvp/+Ve8hhYmibgzwwNrvB3OgAWXN1iedFYMztGIXZdCS8s777oUR
IxGsFVV/b2jiENT14oi5z3/Q0QY2phQkBxI28GnghpNI3fuz3a+k8UuueS4KWshJ
QJCEPgicVKft33TIf62yRSaincFpdoOOSt+PCzs8al9Bzim1X41kumntX1wkhzqG
8pcr+zjUPuAewHAEUhn5eiKAGo+psXMtDX862w8gahi54Do7ehdcJdZ181k5Rjsj
1lIHrz62cj5sDYTkH0cDl0R1910UUWmkYpFIb/1O4kB9bNou27VBhGZVP7kew9Wf
CaBUwGf1Y+D+JPEsGuxBrw+EsKpiWEF64tssTmaOi6rrCFiGC11BzSBofnjLa+Ll
XZIf0NMpiPLPQngl8VaBDz/iIjWOBBOx3wbHGVccxhxSE/Npdxfb3U7MamGTbpce
8mNdB3htvhG0+ViIUmtMgqG2p+xPkRVcSufmrvWfQ5ZjQLKfCwcMCR/9CWD4LTxF
NkidWf7X+48y+O2hcb8VRrx8Vzf2ouJlAfI5nK+YhusnqqcyLKhifN+5km5Ea5zm
ujzSNf4vTEqJqs37NIM3ISQFwa/Mxfun3gUrfdUEgtbCPqglgIDwJP9pxWVZVPAo
xWrLFqTZt2NpKf7VVSbUj9M+rBq4HMfVU0e/BA4iFCnmyYd6rbU=
=nRgv
-----END PGP SIGNATURE-----

Jakob L. Kreuze wrote 6 years ago
Re: [bug#36952] [PATCH v3] machine: Implement 'roll-back-machine'.
(name . Ricardo Wurmus)(address . rekado@elephly.net)
87y303jtt7.fsf_-_@sdf.lonestar.org
* gnu/machine.scm (roll-back-machine, &deploy-error, deploy-error?)
(deploy-error-should-roll-back)
(deploy-error-captured-args): New variable.
* gnu/machine/ssh.scm (roll-back-managed-host): New variable.
* guix/scripts/deploy.scm (guix-deploy): Roll-back systems when a
deployment fails.
---
gnu/machine.scm | 27 ++++++++++++++-
gnu/machine/ssh.scm | 73 +++++++++++++++++++++++++++++++++++++++--
guix/remote.scm | 1 +
guix/scripts/deploy.scm | 17 ++++++++--
4 files changed, 112 insertions(+), 6 deletions(-)

Toggle diff (219 lines)
diff --git a/gnu/machine.scm b/gnu/machine.scm
index 30ae97f6ec..05b03b21d4 100644
--- a/gnu/machine.scm
+++ b/gnu/machine.scm
@@ -24,6 +24,7 @@
#:use-module (guix records)
#:use-module (guix store)
#:use-module ((guix utils) #:select (source-properties->location))
+ #:use-module (srfi srfi-35)
#:export (environment-type
environment-type?
environment-type-name
@@ -40,7 +41,13 @@
machine-display-name
deploy-machine
- machine-remote-eval))
+ roll-back-machine
+ machine-remote-eval
+
+ &deploy-error
+ deploy-error?
+ deploy-error-should-roll-back
+ deploy-error-captured-args))
;;; Commentary:
;;;
@@ -66,6 +73,7 @@
;; of the form '(machine-remote-eval machine exp)'.
(machine-remote-eval environment-type-machine-remote-eval) ; procedure
(deploy-machine environment-type-deploy-machine) ; procedure
+ (roll-back-machine environment-type-roll-back-machine) ; procedure
;; Metadata.
(name environment-type-name) ; symbol
@@ -105,3 +113,20 @@ are built and deployed to MACHINE beforehand."
MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
(let ((environment (machine-environment machine)))
((environment-type-deploy-machine environment) machine)))
+
+(define (roll-back-machine machine)
+ "Monadic procedure rolling back to the previous system generation on
+MACHINE. Return the number of the generation that was current before switching
+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 ba3e33c922..2cfb3f20f1 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu machine ssh)
+ #:use-module (gnu bootloader)
#:use-module (gnu machine)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu system)
@@ -34,8 +35,10 @@
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (managed-host-environment-type
@@ -310,6 +313,18 @@ of MACHINE's system profile, ordered from most recent to oldest."
(boot-parameters-kernel-arguments params))))))))
generations))))
+(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."
@@ -322,9 +337,60 @@ environment type of 'managed-host."
(bootloader-configuration (operating-system-bootloader os))
(bootcfg (operating-system-bootcfg os menu-entries)))
(mbegin %store-monad
- (switch-to-system eval os)
- (upgrade-shepherd-services eval os)
- (install-bootloader eval bootloader-configuration bootcfg)))))
+ (with-roll-back #f
+ (switch-to-system eval os))
+ (with-roll-back #t
+ (mbegin %store-monad
+ (upgrade-shepherd-services eval os)
+ (install-bootloader eval bootloader-configuration bootcfg)))))))
+
+
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-managed-host machine)
+ "Internal implementation of 'roll-back-machine' for MACHINE instances with
+an environment type of 'managed-host."
+ (define remote-exp
+ (with-extensions (list guile-gcrypt)
+ (with-imported-modules (source-module-closure '((guix config)
+ (guix profiles)))
+ #~(begin
+ (use-modules (guix config)
+ (guix profiles))
+
+ (define %system-profile
+ (string-append %state-directory "/profiles/system"))
+
+ (define target-generation
+ (relative-generation %system-profile -1))
+
+ (if target-generation
+ (switch-to-generation %system-profile target-generation)
+ 'error)))))
+
+ (define roll-back-failure
+ (condition (&message (message (G_ "could not roll-back machine")))))
+
+ (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
+ (_ -> (if (< (length boot-parameters) 2)
+ (raise roll-back-failure)))
+ (entries -> (map boot-parameters->menu-entry
+ (list (second boot-parameters))))
+ (old-entries -> (map boot-parameters->menu-entry
+ (drop boot-parameters 2)))
+ (bootloader -> (operating-system-bootloader
+ (machine-operating-system machine)))
+ (bootcfg (lower-object
+ ((bootloader-configuration-file-generator
+ (bootloader-configuration-bootloader
+ bootloader))
+ bootloader entries
+ #:old-entries old-entries)))
+ (remote-result (machine-remote-eval machine remote-exp)))
+ (when (eqv? 'error remote-result)
+ (raise roll-back-failure))))
;;;
@@ -335,6 +401,7 @@ environment type of 'managed-host."
(environment-type
(machine-remote-eval managed-host-remote-eval)
(deploy-machine deploy-managed-host)
+ (roll-back-machine roll-back-managed-host)
(name 'managed-host-environment-type)
(description "Provisioning for machines that are accessible over SSH
and have a known host-name. This entails little more than maintaining an SSH
diff --git a/guix/remote.scm b/guix/remote.scm
index 5fecd954e9..853029c54f 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -24,6 +24,7 @@
#:use-module (guix monads)
#:use-module (guix modules)
#:use-module (guix derivations)
+ #:use-module (guix utils)
#:use-module (ssh popen)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index ebc99e52cc..d16e7d7480 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -28,6 +28,8 @@
#:use-module (guix grafts)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:export (guix-deploy))
@@ -91,8 +93,19 @@ Perform the deployment specified by FILE.\n"))
(with-store store
(set-build-options-from-command-line store opts)
(for-each (lambda (machine)
- (info (G_ "deploying to ~a...") (machine-display-name machine))
+ (info (G_ "deploying to ~a...~%")
+ (machine-display-name machine))
(parameterize ((%current-system (assq-ref opts 'system))
(%graft? (assq-ref opts 'graft?)))
- (run-with-store store (deploy-machine 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)))))
machines))))
--
2.22.0
-----BEGIN PGP SIGNATURE-----

iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl1Mg1UACgkQ9Qb9Fp2P
2VqeWQ/7B8s8LgrovGc1eYdICmHziTy8BsiJF5un9sYpGR9H8u6I2ijJSXtOU3oF
xzGE0AGS3YvFVAuKxhQRQYFO//i7EFHHowdUdW64EvZzukbjpVU9lXxXCnYVm+vu
qLWAoYa8q6VhiRAk6L/7VWHibFq2t6u2iX/Yvl1fO0LPxC0SBnLRFRD168M3v44x
KuWZxBpmwlWtisbQ3zrctKUAxUBpIvmJGENTa98o41DaytN7Fa0ijD88Sf5Dv6Gw
y6kjtv86ZaBMzozNr+xjwkeWHxTiEyuxt9BslXPFsQL0Dt7prnihEjO4kqC4vjNu
vvvkD53ab2UmscMp+fBy/k1NEWNuXGvShNqbn39kgP9YX4FYYol/NWpXCpZmB+TS
Oos88HH2SE2vLj3Z0SgPOWTKLHYsMK/CIezvt+L3HlSoy5kc43fhIL595/0lq5Ce
ZLPcGAd+ttRfgVabEd5pS3x3DHpzmkTDed6582zHehws/EngCG5SrIsx6HsZWOGQ
gY9Xw6GzUUG2BG19OSJ5cINusQ19Mw7kkvDee+b89msLp/V5t934LhI4JdzDqn/1
BX7KjdEtO8lERPUJPdpI7KApCVSKvVPLyTqeEWiT/cj5UkM7dpmEgAFozarNZIZN
LIVo3lvAj7tSvI5kFJeYmfi9gSAxBpRaGSKeRnmMrzjlLnDHt/E=
=4a4M
-----END PGP SIGNATURE-----

Christopher Lemmer Webber wrote 6 years ago
Re: [bug#36952] [PATCH] machine: Implement 'roll-back-machine'.
(address . guix-patches@gnu.org)(address . 36952@debbugs.gnu.org)
87k1bfxyjc.fsf@dustycloud.org
Looks good. Will merge when in patch series form.

Jakob L. Kreuze writes:

Toggle quote (231 lines)
> * gnu/machine.scm (roll-back-machine, &deploy-error, deploy-error?)
> (deploy-error-should-roll-back)
> (deploy-error-captured-args): New variable.
> * gnu/machine/ssh.scm (roll-back-managed-host): New variable.
> * guix/scripts/deploy.scm (guix-deploy): Roll-back systems when a
> deployment fails.
> ---
> gnu/machine.scm | 27 ++++++++++++++-
> gnu/machine/ssh.scm | 75 +++++++++++++++++++++++++++++++++++++++--
> guix/remote.scm | 1 +
> guix/scripts/deploy.scm | 17 ++++++++--
> 4 files changed, 114 insertions(+), 6 deletions(-)
>
> diff --git a/gnu/machine.scm b/gnu/machine.scm
> index 30ae97f6ec..05b03b21d4 100644
> --- a/gnu/machine.scm
> +++ b/gnu/machine.scm
> @@ -24,6 +24,7 @@
> #:use-module (guix records)
> #:use-module (guix store)
> #:use-module ((guix utils) #:select (source-properties->location))
> + #:use-module (srfi srfi-35)
> #:export (environment-type
> environment-type?
> environment-type-name
> @@ -40,7 +41,13 @@
> machine-display-name
>
> deploy-machine
> - machine-remote-eval))
> + roll-back-machine
> + machine-remote-eval
> +
> + &deploy-error
> + deploy-error?
> + deploy-error-should-roll-back
> + deploy-error-captured-args))
>
> ;;; Commentary:
> ;;;
> @@ -66,6 +73,7 @@
> ;; of the form '(machine-remote-eval machine exp)'.
> (machine-remote-eval environment-type-machine-remote-eval) ; procedure
> (deploy-machine environment-type-deploy-machine) ; procedure
> + (roll-back-machine environment-type-roll-back-machine) ; procedure
>
> ;; Metadata.
> (name environment-type-name) ; symbol
> @@ -105,3 +113,20 @@ are built and deployed to MACHINE beforehand."
> MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
> (let ((environment (machine-environment machine)))
> ((environment-type-deploy-machine environment) machine)))
> +
> +(define (roll-back-machine machine)
> + "Monadic procedure rolling back to the previous system generation on
> +MACHINE. Return the number of the generation that was current before switching
> +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 274d56db26..ae312597dd 100644
> --- a/gnu/machine/ssh.scm
> +++ b/gnu/machine/ssh.scm
> @@ -17,6 +17,7 @@
> ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
>
> (define-module (gnu machine ssh)
> + #:use-module (gnu bootloader)
> #:use-module (gnu machine)
> #:autoload (gnu packages gnupg) (guile-gcrypt)
> #:use-module (gnu system)
> @@ -34,8 +35,10 @@
> #:use-module (guix store)
> #:use-module (guix utils)
> #:use-module (ice-9 match)
> + #:use-module (srfi srfi-1)
> #:use-module (srfi srfi-19)
> #:use-module (srfi srfi-26)
> + #:use-module (srfi srfi-34)
> #:use-module (srfi srfi-35)
> #:export (managed-host-environment-type
>
> @@ -304,6 +307,18 @@ of MACHINE's system profile, ordered from most recent to oldest."
> (boot-parameters-kernel-arguments params))))))))
> generations))))
>
> +(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."
> @@ -316,9 +331,62 @@ environment type of 'managed-host."
> (bootloader-configuration (operating-system-bootloader os))
> (bootcfg (operating-system-bootcfg os menu-entries)))
> (mbegin %store-monad
> - (switch-to-system eval os)
> - (upgrade-shepherd-services eval os)
> - (install-bootloader eval bootloader-configuration bootcfg)))))
> + (with-roll-back #f
> + (switch-to-system eval os))
> + (with-roll-back #t
> + (mbegin %store-monad
> + (upgrade-shepherd-services eval os)
> + (install-bootloader eval bootloader-configuration bootcfg)))))))
> +
> +
> +;;;
> +;;; Roll-back.
> +;;;
> +
> +(define (roll-back-managed-host machine)
> + "Internal implementation of 'roll-back-machine' for MACHINE instances with
> +an environment type of 'managed-host."
> + (define remote-exp
> + (with-extensions (list guile-gcrypt)
> + (with-imported-modules (source-module-closure '((guix config)
> + (guix profiles)))
> + #~(begin
> + (use-modules (guix config)
> + (guix profiles))
> +
> + (define %system-profile
> + (string-append %state-directory "/profiles/system"))
> +
> + (define target-generation
> + (relative-generation-spec->number %system-profile "-1"))
> +
> + (if target-generation
> + (switch-to-generation %system-profile target-generation)
> + 'error)))))
> +
> + (define roll-back-failure
> + (condition (&message (message (G_ "could not roll-back machine")))))
> +
> + (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
> + (_ -> (if (< (length boot-parameters) 2)
> + (raise roll-back-failure)))
> + (entries -> (map boot-parameters->menu-entry
> + (list (second boot-parameters))))
> + (old-entries -> (map boot-parameters->menu-entry
> + (drop boot-parameters 2)))
> + (bootloader -> (operating-system-bootloader
> + (machine-operating-system machine)))
> + (bootcfg (lower-object
> + ((bootloader-configuration-file-generator
> + (bootloader-configuration-bootloader
> + bootloader))
> + bootloader entries
> + #:old-entries old-entries)))
> + (eval -> (cut machine-remote-eval machine <>))
> + (remote-result (machine-remote-eval machine
> + remote-exp)))
> + (when (eqv? 'error remote-result)
> + (raise roll-back-failure))))
>
>
> ;;;
> @@ -329,6 +397,7 @@ environment type of 'managed-host."
> (environment-type
> (machine-remote-eval managed-host-remote-eval)
> (deploy-machine deploy-managed-host)
> + (roll-back-machine roll-back-managed-host)
> (name 'managed-host-environment-type)
> (description "Provisioning for machines that are accessible over SSH
> and have a known host-name. This entails little more than maintaining an SSH
> diff --git a/guix/remote.scm b/guix/remote.scm
> index 0a0bdaf30b..d5738ebbfa 100644
> --- a/guix/remote.scm
> +++ b/guix/remote.scm
> @@ -24,6 +24,7 @@
> #:use-module (guix monads)
> #:use-module (guix modules)
> #:use-module (guix derivations)
> + #:use-module (guix utils)
> #:use-module (ssh popen)
> #:use-module (srfi srfi-1)
> #:use-module (ice-9 match)
> diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
> index 52d5e1e1da..bc1d93a93a 100644
> --- a/guix/scripts/deploy.scm
> +++ b/guix/scripts/deploy.scm
> @@ -27,6 +27,8 @@
> #:use-module (guix grafts)
> #:use-module (ice-9 format)
> #:use-module (srfi srfi-1)
> + #:use-module (srfi srfi-34)
> + #:use-module (srfi srfi-35)
> #:use-module (srfi srfi-37)
> #:export (guix-deploy))
>
> @@ -84,7 +86,18 @@ Perform the deployment specified by FILE.\n"))
> (with-store store
> (set-build-options-from-command-line store opts)
> (for-each (lambda (machine)
> - (info (G_ "deploying to ~a...") (machine-display-name machine))
> + (info (G_ "deploying to ~a...~%")
> + (machine-display-name machine))
> (parameterize ((%graft? (assq-ref opts 'graft?)))
> - (run-with-store store (deploy-machine 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)))))
> machines))))
Christopher Lemmer Webber wrote 6 years ago
(address . 36952-done@debbugs.gnu.org)
87d0h6y7mh.fsf@dustycloud.org
Merged and pushed!
Closed
?
Your comment

This issue is archived.

To comment on this conversation send an email to 36952@debbugs.gnu.org

To respond to this issue using the mumi CLI, first switch to it
mumi current 36952
Then, you may apply the latest patchset in this issue (with sign off)
mumi am -- -s
Or, compose a reply to this issue
mumi compose
Or, send patches to this issue
mumi send-email *.patch
You may also tag this issue. See list of standard tags. For example, to set the confirmed and easy tags
mumi command -t +confirmed -t +easy
Or, remove the moreinfo tag and set the help tag
mumi command -t -moreinfo -t +help