[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#36952] [PATCH] machine: Implement 'roll-back-machine'.
From: |
Christopher Lemmer Webber |
Subject: |
[bug#36952] [PATCH] machine: Implement 'roll-back-machine'. |
Date: |
Wed, 14 Aug 2019 16:49:43 -0400 |
User-agent: |
mu4e 1.2.0; emacs 26.2 |
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))))