[bug#75414] [PATCH 0/2] Add roll-back action to guix deploy

[bug#75414] [PATCH 0/2] Add roll-back action to guix deploy

[Arun Isaac]

Hi,

I implement a roll-back action for guix deploy. This is convenient to roll
back all machines in a `guix deploy' configuration.

By the by, PATCH 1 fixes a bug necessary to make this work.

Regards,
Arun

Arun Isaac (2):
  machine: ssh: Return monadic value from roll-back-managed-host.
  deploy: Add roll-back action.

 doc/guix.texi           |  7 ++++
 gnu/machine/ssh.scm     |  6 ++-
 guix/scripts/deploy.scm | 90 +++++++++++++++++++++++++++++++++--------
 3 files changed, 84 insertions(+), 19 deletions(-)


base-commit: 67a535351f8678969e412e8dba9197a883b524d0
-- 
2.47.1

[bug#75414] [PATCH 1/2] machine: ssh: Return monadic value from roll-back-managed-host.

[Arun Isaac]

Previously, <unspecified> would be returned. That was a bug. Monadic
procedures must always return monadic values.

* gnu/machine/ssh.scm (roll-back-managed-host): Return monadic value.

Change-Id: I3db2879dbfbcab5e9d251fa5ed02c8653adbeafb
---
 gnu/machine/ssh.scm | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index bc4289ef7d..73d5dc513e 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
 ;;; Copyright © 2020-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2024 Ricardo <rekado@elephly.net>
+;;; Copyright © 2025 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -621,8 +622,9 @@ (define (roll-back-managed-host machine)
                                   #:store-directory-prefix store-dir
                                   #:old-entries old-entries)))
                        (remote-result (machine-remote-eval machine remote-exp)))
-    (when (eqv? 'error remote-result)
-      (raise roll-back-failure))))
+    (if (eqv? 'error remote-result)
+        (raise roll-back-failure)
+        (return remote-result))))
 
 \f
 ;;;
-- 
2.47.1

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

[Arun Isaac]

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

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)
 \f
 
 (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))))))))))))
-- 
2.47.1