[bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'.

[Christopher Lemmer Webber <cwebber@dustycloud.org>]

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)))
> +
> +\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 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))))