[bug#36952,v2] machine: Implement 'roll-back-machine'.
diff mbox series

Message ID 87v9v8k82l.fsf_-_@sdf.lonestar.org
State New
Headers show
Series
  • [bug#36952,v2] machine: Implement 'roll-back-machine'.
Related show

Commit Message

Jakob L. Kreuze Aug. 7, 2019, 8:57 p.m. UTC
* 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(-)

Comments

Christopher Lemmer Webber Aug. 7, 2019, 10:33 p.m. UTC | #1
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)))
> +
> +
> +;;;
> +;;; 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 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))))
Ricardo Wurmus Aug. 8, 2019, 10:50 a.m. UTC | #2
Hi Jakob,

> +(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"))

Can we use “relative-generation” or “previous-generation-number” here?
I think the stringified “-1” is kinda ugly, and the “*-spec” procedure
only exists to handle user input, which is provided as a string.

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

Is it on purpose that you aren’t using the previously defined “eval”
here?

--
Ricardo
Jakob L. Kreuze Aug. 8, 2019, 8:16 p.m. UTC | #3
Hi Ricardo,

Ricardo Wurmus <rekado@elephly.net> writes:

> Can we use “relative-generation” or “previous-generation-number” here?
> I think the stringified “-1” is kinda ugly, and the “*-spec” procedure
> only exists to handle user input, which is provided as a string.

Oh yeah, definitely. I used '*-spec' here because I was using 'guix
system' as a model -- didn't know it was meant for handling user input.

> Is it on purpose that you aren’t using the previously defined “eval”
> here?

Whoops! Unused variable, nice catch!

Thanks for the review!

Regards,
Jakob

Patch
diff mbox series

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