[bug#75414,2/2] deploy: Add roll-back action.

Message ID 48a1e0e70b6e9aef50c847e5882fd996c0a5476d.1736208948.git.arunisaac@systemreboot.net
State New
Headers
Series Add roll-back action to guix deploy |

Commit Message

Arun Isaac Jan. 7, 2025, 12:28 a.m. UTC
  * guix/scripts/deploy.scm (guix-deploy): Add the roll-back action.
(show-what-to-deploy): Optionally support the roll-back action.
(roll-back-machine*): New function.
(show-help): Document the roll-back action.
* doc/guix.texi (Invoking guix deploy): Document the roll-back action.

Change-Id: Ic5084f287aefb2d1d28380ca4ba1c6971cb913e7
---
 doc/guix.texi           |  7 ++++
 guix/scripts/deploy.scm | 90 +++++++++++++++++++++++++++++++++--------
 2 files changed, 80 insertions(+), 17 deletions(-)
  

Comments

Ludovic Courtès Jan. 19, 2025, 10:07 p.m. UTC | #1
Arun Isaac <arunisaac@systemreboot.net> skribis:

> * guix/scripts/deploy.scm (guix-deploy): Add the roll-back action.
> (show-what-to-deploy): Optionally support the roll-back action.
> (roll-back-machine*): New function.
> (show-help): Document the roll-back action.
> * doc/guix.texi (Invoking guix deploy): Document the roll-back action.
>
> Change-Id: Ic5084f287aefb2d1d28380ca4ba1c6971cb913e7

[...]

> +You may also wish to roll back configurations on machines to a previous
> +generation.  You can do that using
                                     ^
I would add a colon.

>  (define (show-help)
> -  (display (G_ "Usage: guix deploy [OPTION] FILE...
> -Perform the deployment specified by FILE.\n"))
> +  (display (G_ "Usage: guix deploy [OPTION] [ACTION] FILE...

Hmm I would rather have ‘guix deploy --roll-back’, although that’d be
different from ‘guix system’, primarily because I don’t see what other
actions we could have, and in particular how we’d name the default
action (‘guix deploy deploy’? ‘guix deploy really’? ‘guix deploy
please’?).

Tough issue!

But note that if we make it a ‘--roll-back’ option, we can easily change
our mind later and make it an action, whereas the converse would be more
difficult.

Apart from that it looks great to me.

Thank you!

Ludo’.
  

Patch

diff --git a/doc/guix.texi b/doc/guix.texi
index b2bcab8791..c08c2c70ef 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -44354,6 +44354,13 @@  Invoking guix deploy
 The @command{guix deploy -x} command returns zero if and only if the
 command succeeded on all the machines.
 
+You may also wish to roll back configurations on machines to a previous
+generation.  You can do that using
+
+@example
+guix deploy roll-back @var{file}
+@end example
+
 @c FIXME/TODO: Separate the API doc from the CLI doc.
 
 Below are the data types you need to know about when writing a
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 941ee199f0..3f1b8b27a7 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -3,6 +3,7 @@ 
 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
 ;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2024 Richard Sent <richard@freakingpenguin.com>
+;;; Copyright © 2025 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -50,8 +51,13 @@  (define-module (guix scripts deploy)
 
 
 (define (show-help)
-  (display (G_ "Usage: guix deploy [OPTION] FILE...
-Perform the deployment specified by FILE.\n"))
+  (display (G_ "Usage: guix deploy [OPTION] [ACTION] FILE...
+Perform the deployment specified by FILE.
+Optionally, perform ACTION.\n\n"))
+  (display (G_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (G_ "\
+   roll-back        switch to the previous operating system configuration\n"))
   (show-build-options-help)
   (newline)
   (display (G_ "
@@ -118,20 +124,32 @@  (define (load-source-file file)
                                            environment-modules))))
     (load* file module)))
 
-(define* (show-what-to-deploy machines #:key (dry-run? #f))
-  "Show the list of machines to deploy, MACHINES."
+(define* (show-what-to-deploy machines #:key (dry-run? #f) (roll-back? #f))
+  "Show the list of machines in MACHINES to deploy or roll back."
   (let ((count (length machines)))
     (if dry-run?
-        (format (current-error-port)
-                (N_ "The following ~d machine would be deployed:~%"
-                    "The following ~d machines would be deployed:~%"
+        (if roll-back?
+            (format (current-error-port)
+                (N_ "The following ~d machine would be rolled back:~%"
+                    "The following ~d machines would be rolled back:~%"
                     count)
                 count)
-        (format (current-error-port)
-                (N_ "The following ~d machine will be deployed:~%"
-                    "The following ~d machines will be deployed:~%"
+            (format (current-error-port)
+                    (N_ "The following ~d machine would be deployed:~%"
+                        "The following ~d machines would be deployed:~%"
+                        count)
+                    count))
+        (if roll-back?
+            (format (current-error-port)
+                    (N_ "The following ~d machine will be rolled back:~%"
+                        "The following ~d machines will be rolled back:~%"
+                        count)
                     count)
-                count))
+            (format (current-error-port)
+                    (N_ "The following ~d machine will be deployed:~%"
+                        "The following ~d machines will be deployed:~%"
+                        count)
+                    count)))
     (display (indented-string
               (fill-paragraph (string-join (map machine-display-name machines)
                                            ", ")
@@ -175,6 +193,35 @@  (define (deploy-machine* store machine)
     (info (G_ "successfully deployed ~a~%")
           (machine-display-name machine))))
 
+(define (roll-back-machine* store machine)
+  "Roll back MACHINE, taking care of error handling."
+  (info (G_ "rolling back ~a...~%")
+        (machine-display-name machine))
+
+  (guard* (c
+           ;; On Guile 3.0, exceptions such as 'unbound-variable' are compound
+           ;; and include a '&message'.  However, that message only contains
+           ;; the format string.  Thus, special-case it here to avoid
+           ;; displaying a bare format string.
+           (((exception-predicate &exception-with-kind-and-args) c)
+            (raise c))
+
+           ((message-condition? c)
+            (leave (G_ "failed to roll back ~a: ~a~%")
+                   (machine-display-name machine)
+                   (condition-message c)))
+           ((formatted-message? c)
+            (leave (G_ "failed to roll back ~a: ~a~%")
+                   (machine-display-name machine)
+                   (apply format #f
+                          (gettext (formatted-message-string c)
+                                   %gettext-domain)
+                          (formatted-message-arguments c)))))
+      (run-with-store store (roll-back-machine machine)))
+
+  (info (G_ "successfully rolled back ~a~%")
+        (machine-display-name machine)))
+
 (define (invoke-command store machine command)
   "Invoke COMMAND, a list of strings, on MACHINE.  Display its output (if any)
 and its error code if it's non-zero.  Return true if COMMAND succeeded, false
@@ -291,9 +338,18 @@  (define-command (guix-deploy . args)
                             machines)))
                     (_
                      (leave (G_ "'-x' specified but no command given~%"))))
-                  (begin
-                    (show-what-to-deploy machines #:dry-run? dry-run?)
-                    (unless dry-run?
-                      (map/accumulate-builds store
-                                             (cut deploy-machine* store <>)
-                                             machines)))))))))))
+                  (match args
+                    (("roll-back" _ ...)
+                     (show-what-to-deploy machines
+                                          #:dry-run? dry-run?
+                                          #:roll-back? #t)
+                     (unless dry-run?
+                       (map/accumulate-builds store
+                                              (cut roll-back-machine* store <>)
+                                              machines)))
+                    (_
+                     (show-what-to-deploy machines #:dry-run? dry-run?)
+                     (unless dry-run?
+                       (map/accumulate-builds store
+                                              (cut deploy-machine* store <>)
+                                              machines))))))))))))