* [bug#36952] [PATCH] machine: Implement 'roll-back-machine'.
@ 2019-08-07 12:42 Jakob L. Kreuze
2019-08-07 20:11 ` Christopher Lemmer Webber
2019-08-14 20:49 ` [bug#36952] [PATCH] " Christopher Lemmer Webber
0 siblings, 2 replies; 9+ messages in thread
From: Jakob L. Kreuze @ 2019-08-07 12:42 UTC (permalink / raw)
To: 36952
[-- Attachment #1: Type: text/plain, Size: 9680 bytes --]
* 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)))
+
+\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 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)))))))
+
+\f
+;;;
+;;; 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))))
\f
;;;
@@ -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
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [bug#36952] [PATCH] machine: Implement 'roll-back-machine'.
2019-08-07 12:42 [bug#36952] [PATCH] machine: Implement 'roll-back-machine' Jakob L. Kreuze
@ 2019-08-07 20:11 ` Christopher Lemmer Webber
2019-08-07 20:57 ` [bug#36952] [PATCH v2] " Jakob L. Kreuze
2019-08-14 20:49 ` [bug#36952] [PATCH] " Christopher Lemmer Webber
1 sibling, 1 reply; 9+ messages in thread
From: Christopher Lemmer Webber @ 2019-08-07 20:11 UTC (permalink / raw)
To: 36952
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:
> * 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)))
> +
> +\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 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)))))))
> +
> +\f
> +;;;
> +;;; 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))))
>
> \f
> ;;;
> @@ -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))))
^ permalink raw reply [flat|nested] 9+ messages in thread
* [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'.
2019-08-07 20:11 ` Christopher Lemmer Webber
@ 2019-08-07 20:57 ` Jakob L. Kreuze
2019-08-07 22:33 ` Christopher Lemmer Webber
2019-08-08 10:50 ` Ricardo Wurmus
0 siblings, 2 replies; 9+ messages in thread
From: Jakob L. Kreuze @ 2019-08-07 20:57 UTC (permalink / raw)
To: Christopher Lemmer Webber; +Cc: 36952
[-- Attachment #1: Type: text/plain, Size: 9755 bytes --]
* 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)))
+
+\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 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)))))))
+
+\f
+;;;
+;;; 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))))
\f
;;;
@@ -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
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'.
2019-08-07 20:57 ` [bug#36952] [PATCH v2] " Jakob L. Kreuze
@ 2019-08-07 22:33 ` Christopher Lemmer Webber
2019-08-08 10:50 ` Ricardo Wurmus
1 sibling, 0 replies; 9+ messages in thread
From: Christopher Lemmer Webber @ 2019-08-07 22:33 UTC (permalink / raw)
To: Jakob L. Kreuze, David Thompson; +Cc: 36952
Thanks. I'm going to specifically loop in Dave...
Dave, mind peering over this before I merge it?
Jakob L. Kreuze writes:
> * 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)))
> +
> +\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 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)))))))
> +
> +\f
> +;;;
> +;;; 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))))
>
> \f
> ;;;
> @@ -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))))
^ permalink raw reply [flat|nested] 9+ messages in thread
* [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'.
2019-08-07 20:57 ` [bug#36952] [PATCH v2] " Jakob L. Kreuze
2019-08-07 22:33 ` Christopher Lemmer Webber
@ 2019-08-08 10:50 ` Ricardo Wurmus
2019-08-08 20:16 ` Jakob L. Kreuze
2019-08-08 20:17 ` [bug#36952] [PATCH v3] " Jakob L. Kreuze
1 sibling, 2 replies; 9+ messages in thread
From: Ricardo Wurmus @ 2019-08-08 10:50 UTC (permalink / raw)
To: Jakob L. Kreuze; +Cc: 36952
Hi Jakob,
> +(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.
> + (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
^ permalink raw reply [flat|nested] 9+ messages in thread
* [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'.
2019-08-08 10:50 ` Ricardo Wurmus
@ 2019-08-08 20:16 ` Jakob L. Kreuze
2019-08-08 20:17 ` [bug#36952] [PATCH v3] " Jakob L. Kreuze
1 sibling, 0 replies; 9+ messages in thread
From: Jakob L. Kreuze @ 2019-08-08 20:16 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 36952
[-- Attachment #1: Type: text/plain, Size: 612 bytes --]
Hi Ricardo,
Ricardo Wurmus <rekado@elephly.net> writes:
> 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.
> 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
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]
^ permalink raw reply [flat|nested] 9+ messages in thread
* [bug#36952] [PATCH v3] machine: Implement 'roll-back-machine'.
2019-08-08 10:50 ` Ricardo Wurmus
2019-08-08 20:16 ` Jakob L. Kreuze
@ 2019-08-08 20:17 ` Jakob L. Kreuze
1 sibling, 0 replies; 9+ messages in thread
From: Jakob L. Kreuze @ 2019-08-08 20:17 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 36952
[-- Attachment #1: Type: text/plain, Size: 9609 bytes --]
* 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(-)
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)))
+
+\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 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)))))))
+
+\f
+;;;
+;;; 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))))
\f
;;;
@@ -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
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [bug#36952] [PATCH] machine: Implement 'roll-back-machine'.
2019-08-07 12:42 [bug#36952] [PATCH] machine: Implement 'roll-back-machine' Jakob L. Kreuze
2019-08-07 20:11 ` Christopher Lemmer Webber
@ 2019-08-14 20:49 ` Christopher Lemmer Webber
2019-08-15 11:45 ` bug#36952: " Christopher Lemmer Webber
1 sibling, 1 reply; 9+ messages in thread
From: Christopher Lemmer Webber @ 2019-08-14 20:49 UTC (permalink / raw)
To: 36952
Looks good. Will merge when in patch series form.
Jakob L. Kreuze writes:
> * 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)))
> +
> +\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 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)))))))
> +
> +\f
> +;;;
> +;;; 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))))
>
> \f
> ;;;
> @@ -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))))
^ permalink raw reply [flat|nested] 9+ messages in thread
* bug#36952: [PATCH] machine: Implement 'roll-back-machine'.
2019-08-14 20:49 ` [bug#36952] [PATCH] " Christopher Lemmer Webber
@ 2019-08-15 11:45 ` Christopher Lemmer Webber
0 siblings, 0 replies; 9+ messages in thread
From: Christopher Lemmer Webber @ 2019-08-15 11:45 UTC (permalink / raw)
To: 36952-done
Merged and pushed!
^ permalink raw reply [flat|nested] 9+ messages in thread
end of thread, other threads:[~2019-08-15 11:46 UTC | newest]
Thread overview: 9+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2019-08-07 12:42 [bug#36952] [PATCH] machine: Implement 'roll-back-machine' Jakob L. Kreuze
2019-08-07 20:11 ` Christopher Lemmer Webber
2019-08-07 20:57 ` [bug#36952] [PATCH v2] " Jakob L. Kreuze
2019-08-07 22:33 ` Christopher Lemmer Webber
2019-08-08 10:50 ` Ricardo Wurmus
2019-08-08 20:16 ` Jakob L. Kreuze
2019-08-08 20:17 ` [bug#36952] [PATCH v3] " Jakob L. Kreuze
2019-08-14 20:49 ` [bug#36952] [PATCH] " Christopher Lemmer Webber
2019-08-15 11:45 ` bug#36952: " Christopher Lemmer Webber
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).