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

DoneSubmitted by Jakob L. Kreuze.
Details
2 participants
  • Ludovic Courtès
  • Jakob L. Kreuze
Owner
unassigned
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 adeployment 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.scmindex 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.scmindex 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 SSHdiff --git a/guix/remote.scm b/guix/remote.scmindex 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.scmindex 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/dRoACgkQ9Qb9Fp2P2VojNQ/+Kpo57KyikEbHdQRe8m3P1l80sOzfiOz1h0SxFCyFJ53q8s9XKUnWVGk48zaeUYW3/ZYzBU1yYqZQ5A2OqjWvQrUCHGWmaH2T5sUIYkrQWypHj5pghUwmus9z6h4yW/f9QbbezXnJglQybhIfjD1hw4W+Z9j+F9a/2hVJS1c9ErIY1o4rKo+bl+tu16TfTbt9ynC0CezWgYnItgvIdfW2fxYbGGVwo0NPicBQ4rZOVKh1pUkMJDmozDohjcp5rDN8V5mle0OfCj5qw4LKdCubVngMinJUl/wa/jaX5Tg4QxtYlEnh0En2rCbbUlesnvXxCxmmBynry0PwxAd/w31nT4dM2k3b7avVlxkIdNKLiJsnofl2ashCasa7JNB8VaxIVRQrICl3ubUoFXkfLAH7onK9Gj9tDLjam2a3t7sPm/j/v2NPwI+G5U7hA6naOiQcder9Wiv3moP9Y2x7Qi+9i284YwylX+Lh8bQ4Htsc5B3gf0SxGrlm4xX9wWO2gDIgy7uxy3R1oGe63mIh1HGQ5rgl80yZ3POyZdqwquuIQwisBYWMChA0IH4poL575TGVYki6hEx5GuhItLqaPqWDkQRd7pbKQxT8+I0RY2b0hO9D8QbvHSNGixPd0y8FQYtYYT5v7m8RNXl8sTsjt2MsX1Qt3M2pdixARgcnCF78Ms0==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 closingnow! 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 weshould do something akin to what ‘with-shepherd-error-handling’ does.
WDYT?
Thanks,Ludo’.
Closed
?
Your comment

This issue is archived.

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