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

  • Done
  • quality assurance status badge
Details
2 participants
  • Ludovic Courtès
  • Jakob L. Kreuze
Owner
unassigned
Submitted by
Jakob L. Kreuze
Severity
normal
J
J
Jakob L. Kreuze wrote on 30 Jul 2019 00:37
(address . guix-patches@gnu.org)
87pnlsii1x.fsf@sdf.lonestar.org
* gnu/machine.scm (roll-back-machine, &deploy-error, deploy-error?)
(deploy-error-should-roll-back)
(deploy-error-captured-args): New variable.
* gnu/machine/ssh.scm (roll-back-managed-host): New variable.
* guix/scripts/deploy.scm (guix-deploy): Roll-back systems when a
deployment fails.
---
gnu/machine.scm | 27 ++++++++++++++-
gnu/machine/ssh.scm | 75 +++++++++++++++++++++++++++++++++++++++--
guix/remote.scm | 1 +
guix/scripts/deploy.scm | 17 ++++++++--
4 files changed, 114 insertions(+), 6 deletions(-)

Toggle diff (221 lines)
diff --git a/gnu/machine.scm b/gnu/machine.scm
index 0b79402b0a..a143fd190a 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 552eafa9de..b96e71ddce 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)
@@ -30,8 +31,10 @@
#:use-module (guix ssh)
#:use-module (guix store)
#: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
@@ -161,6 +164,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."
@@ -172,9 +187,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))))
;;;
@@ -185,6 +253,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 52bba3f3bf..8eeb9ae7a1 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))
@@ -87,8 +89,19 @@ Perform the deployment specified by FILE.\n"))
(with-store store
(set-build-options-from-command-line store opts)
(for-each (lambda (machine)
- (info (G_ "deploying to ~a...") (machine-display-name machine))
+ (info (G_ "deploying to ~a...~%")
+ (machine-display-name machine))
(parameterize ((%current-system (assq-ref opts 'system))
(%graft? (assq-ref opts 'graft?)))
- (run-with-store store (deploy-machine machine))))
+ (guard (c ((message-condition? c)
+ (report-error (G_ "failed to deploy ~a: '~a'~%")
+ (machine-display-name machine)
+ (condition-message c)))
+ ((deploy-error? c)
+ (when (deploy-error-should-roll-back c)
+ (info (G_ "rolling back ~a...~%")
+ (machine-display-name machine))
+ (run-with-store store (roll-back-machine machine)))
+ (apply throw (deploy-error-captured-args c))))
+ (run-with-store store (deploy-machine machine)))))
machines))))
--
2.22.0
-----BEGIN PGP SIGNATURE-----

iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl0/dRoACgkQ9Qb9Fp2P
2VojNQ/+Kpo57KyikEbHdQRe8m3P1l80sOzfiOz1h0SxFCyFJ53q8s9XKUnWVGk4
8zaeUYW3/ZYzBU1yYqZQ5A2OqjWvQrUCHGWmaH2T5sUIYkrQWypHj5pghUwmus9z
6h4yW/f9QbbezXnJglQybhIfjD1hw4W+Z9j+F9a/2hVJS1c9ErIY1o4rKo+bl+tu
16TfTbt9ynC0CezWgYnItgvIdfW2fxYbGGVwo0NPicBQ4rZOVKh1pUkMJDmozDoh
jcp5rDN8V5mle0OfCj5qw4LKdCubVngMinJUl/wa/jaX5Tg4QxtYlEnh0En2rCbb
UlesnvXxCxmmBynry0PwxAd/w31nT4dM2k3b7avVlxkIdNKLiJsnofl2ashCasa7
JNB8VaxIVRQrICl3ubUoFXkfLAH7onK9Gj9tDLjam2a3t7sPm/j/v2NPwI+G5U7h
A6naOiQcder9Wiv3moP9Y2x7Qi+9i284YwylX+Lh8bQ4Htsc5B3gf0SxGrlm4xX9
wWO2gDIgy7uxy3R1oGe63mIh1HGQ5rgl80yZ3POyZdqwquuIQwisBYWMChA0IH4p
oL575TGVYki6hEx5GuhItLqaPqWDkQRd7pbKQxT8+I0RY2b0hO9D8QbvHSNGixPd
0y8FQYtYYT5v7m8RNXl8sTsjt2MsX1Qt3M2pdixARgcnCF78Ms0=
=Ptwh
-----END PGP SIGNATURE-----

L
L
Ludovic Courtès wrote on 1 Sep 2019 23:25
(name . Jakob L. Kreuze)(address . zerodaysfordays@sdf.lonestar.org)(address . 36845-done@debbugs.gnu.org)
87imqb7lq3.fsf@gnu.org
Hello Jakob,

This was applied as 9c70c460a05b2bc60f3f3602f0a2dba0f79ce86c, so closing
now! Really nice as usual.

One comment:

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

Toggle quote (12 lines)
> +(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)))))))

If I’m not mistaken, this won’t have the desired effect, and I think we
should do something akin to what ‘with-shepherd-error-handling’ does.

WDYT?

Thanks,
Ludo’.
Closed
?