Package: guix-patches;
Reported by: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze)
Date: Wed, 7 Aug 2019 12:46:02 UTC
Severity: normal
Tags: patch
Done: Christopher Lemmer Webber <cwebber <at> dustycloud.org>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 36952 in the body.
You can then email your comments to 36952 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#36952; Package guix-patches.
(Wed, 07 Aug 2019 12:46:02 GMT) Full text and rfc822 format available.zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze):guix-patches <at> gnu.org.
(Wed, 07 Aug 2019 12:46:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: guix-patches <at> gnu.org Subject: [PATCH] machine: Implement 'roll-back-machine'. Date: Wed, 07 Aug 2019 08:42:08 -0400
[Message part 1 (text/plain, inline)]
* 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))))
--
2.22.0
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#36952; Package guix-patches.
(Wed, 07 Aug 2019 20:12:02 GMT) Full text and rfc822 format available.Message #8 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Christopher Lemmer Webber <cwebber <at> dustycloud.org> To: guix-patches <at> gnu.org Cc: 36952 <at> debbugs.gnu.org Subject: Re: [bug#36952] [PATCH] machine: Implement 'roll-back-machine'. Date: Wed, 07 Aug 2019 16:11:37 -0400
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))) > + > + > +;;; > +;;; 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))))
guix-patches <at> gnu.org:bug#36952; Package guix-patches.
(Wed, 07 Aug 2019 20:12:02 GMT) Full text and rfc822 format available.guix-patches <at> gnu.org:bug#36952; Package guix-patches.
(Wed, 07 Aug 2019 21:01:02 GMT) Full text and rfc822 format available.Message #14 received at 36952 <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: Christopher Lemmer Webber <cwebber <at> dustycloud.org> Cc: 36952 <at> debbugs.gnu.org Subject: Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'. Date: Wed, 07 Aug 2019 16:57:06 -0400
[Message part 1 (text/plain, inline)]
* 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))))
--
2.22.0
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#36952; Package guix-patches.
(Wed, 07 Aug 2019 22:34:01 GMT) Full text and rfc822 format available.Message #17 received at 36952 <at> debbugs.gnu.org (full text, mbox):
From: Christopher Lemmer Webber <cwebber <at> dustycloud.org> To: "Jakob L. Kreuze" <zerodaysfordays <at> sdf.lonestar.org>, "David Thompson" <dthompson2 <at> worcester.edu> Cc: 36952 <at> debbugs.gnu.org Subject: Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'. Date: Wed, 07 Aug 2019 18:33:22 -0400
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))) > + > + > +;;; > +;;; 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))))
guix-patches <at> gnu.org:bug#36952; Package guix-patches.
(Thu, 08 Aug 2019 10:52:02 GMT) Full text and rfc822 format available.Message #20 received at 36952 <at> debbugs.gnu.org (full text, mbox):
From: Ricardo Wurmus <rekado <at> elephly.net> To: Jakob L. Kreuze <zerodaysfordays <at> sdf.lonestar.org> Cc: Christopher Lemmer Webber <cwebber <at> dustycloud.org>, 36952 <at> debbugs.gnu.org Subject: Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'. Date: Thu, 08 Aug 2019 12:50:58 +0200
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
guix-patches <at> gnu.org:bug#36952; Package guix-patches.
(Thu, 08 Aug 2019 20:17:01 GMT) Full text and rfc822 format available.Message #23 received at 36952 <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: Ricardo Wurmus <rekado <at> elephly.net> Cc: Christopher Lemmer Webber <cwebber <at> dustycloud.org>, 36952 <at> debbugs.gnu.org Subject: Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'. Date: Thu, 08 Aug 2019 16:16:35 -0400
[Message part 1 (text/plain, inline)]
Hi Ricardo, Ricardo Wurmus <rekado <at> 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
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#36952; Package guix-patches.
(Thu, 08 Aug 2019 20:18:02 GMT) Full text and rfc822 format available.Message #26 received at 36952 <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: Ricardo Wurmus <rekado <at> elephly.net> Cc: Christopher Lemmer Webber <cwebber <at> dustycloud.org>, 36952 <at> debbugs.gnu.org Subject: Re: [bug#36952] [PATCH v3] machine: Implement 'roll-back-machine'. Date: Thu, 08 Aug 2019 16:17:24 -0400
[Message part 1 (text/plain, inline)]
* 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)))
+
+
+;;;
+;;; 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
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#36952; Package guix-patches.
(Wed, 14 Aug 2019 20:50:02 GMT) Full text and rfc822 format available.Message #29 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Christopher Lemmer Webber <cwebber <at> dustycloud.org> To: guix-patches <at> gnu.org Cc: 36952 <at> debbugs.gnu.org Subject: Re: [bug#36952] [PATCH] machine: Implement 'roll-back-machine'. Date: Wed, 14 Aug 2019 16:49:43 -0400
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))) > + > + > +;;; > +;;; 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))))
guix-patches <at> gnu.org:bug#36952; Package guix-patches.
(Wed, 14 Aug 2019 20:50:03 GMT) Full text and rfc822 format available.Christopher Lemmer Webber <cwebber <at> dustycloud.org>:zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze):Message #37 received at 36952-done <at> debbugs.gnu.org (full text, mbox):
From: Christopher Lemmer Webber <cwebber <at> dustycloud.org> To: 36952-done <at> debbugs.gnu.org Subject: Re: [bug#36952] [PATCH] machine: Implement 'roll-back-machine'. Date: Thu, 15 Aug 2019 07:45:42 -0400
Merged and pushed!
Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Fri, 13 Sep 2019 11:24:08 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.