From: Christopher Lemmer Webber <cwebber@dustycloud.org>
To: 36952@debbugs.gnu.org
Subject: [bug#36952] [PATCH] machine: Implement 'roll-back-machine'.
Date: Wed, 14 Aug 2019 16:49:43 -0400 [thread overview]
Message-ID: <87k1bfxyjc.fsf@dustycloud.org> (raw)
In-Reply-To: <87v9v94067.fsf@sdf.lonestar.org>
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))))
next prev parent reply other threads:[~2019-08-14 20:50 UTC|newest]
Thread overview: 9+ messages / expand[flat|nested] mbox.gz Atom feed top
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 ` Christopher Lemmer Webber [this message]
2019-08-15 11:45 ` bug#36952: [PATCH] " Christopher Lemmer Webber
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87k1bfxyjc.fsf@dustycloud.org \
--to=cwebber@dustycloud.org \
--cc=36952@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.