[bug#75010] [PATCH 1/7] monads: Add 'mmatch'.

[bug#75010] [PATCH 1/7] monads: Add 'mmatch'.

[Herman Rimm via Guix-patches via]

* doc/guix.texi (The Store Monad): Document mmatch.
* guix/monads.scm (mmatch): Add macro.

Change-Id: I558f8e025f6cf788c9fc475e99d49690d7a98f41
---
 doc/guix.texi   |  6 ++++++
 guix/monads.scm | 11 +++++++++++
 2 files changed, 17 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index f7b7569887..c86f644360 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -11814,6 +11814,12 @@ The Store Monad
 (@pxref{Local Bindings,,, guile, GNU Guile Reference Manual}).
 @end defmac
 
+@defmac mmatch monad mexp (pattern body) @dots{}
+Match monadic object @var{mexp} against clause @var{pattern}s, in the
+order in which they appear.  The last expression of each clause
+@var{body} must be a monadic expression.
+@end defmac
+
 @defmac mbegin monad mexp @dots{}
 Bind @var{mexp} and the following monadic expressions in sequence,
 returning the result of the last expression.  Every expression in the
diff --git a/guix/monads.scm b/guix/monads.scm
index 0bd8ac9315..0e8ca868ce 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2017, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -37,6 +38,7 @@ (define-module (guix monads)
             with-monad
             mlet
             mlet*
+            mmatch
             mbegin
             mwhen
             munless
@@ -355,6 +357,15 @@ (define-syntax mlet
              (let ((var temp) ...)
                body ...)))))))
 
+(define-syntax mmatch
+  (syntax-rules ()
+    "Match the monadic object MEXP against the patterns of CLAUSES ...
+in the order in which they appear.  The last expression of each clause
+body must be a monadic expression."
+    ((_ monad mexp clauses ...)
+     (with-monad monad
+       (>>= mexp (match-lambda clauses ...))))))
+
 (define-syntax mbegin
   (syntax-rules (%current-monad)
     "Bind MEXP and the following monadic expressions in sequence, returning
-- 
2.45.2

[bug#75010] [PATCH 2/7] gnu: machine: ssh: Refactor roll-back-managed-host.

[Herman Rimm via Guix-patches via]

* gnu/machine/ssh.scm (roll-back-managed-host): Use let* and mbegin.

Change-Id: Ic3d5039ecf01e1e965dce8a696e7dbd625d2b3c5
---
 gnu/machine/ssh.scm | 53 ++++++++++++++++++++++-----------------------
 1 file changed, 26 insertions(+), 27 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 3e10d984e7..24c36a1936 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -2,6 +2,8 @@
 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
 ;;; Copyright © 2020-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2024 Ricardo <rekado@elephly.net>
+;;; Copyright © 2024 Felix Lechner <felix.lechner@lease-up.com>
+;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -589,33 +591,30 @@ (define (roll-back-managed-host machine)
   (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))))
-                       (locale -> (boot-parameters-locale
-                                   (second boot-parameters)))
-                       (crypto-dev -> (boot-parameters-store-crypto-devices
-                                       (second boot-parameters)))
-                       (store-dir -> (boot-parameters-store-directory-prefix
-                                      (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
-                                  #:locale locale
-                                  #:store-crypto-devices crypto-dev
-                                  #: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))))
+  (mmatch %store-monad (machine-boot-parameters machine)
+    ((_ params rest ...)
+     (let* ((entries (list (boot-parameters->menu-entry params)))
+            (locale (boot-parameters-locale params))
+            (crypto-dev (boot-parameters-store-crypto-devices params))
+            (store-dir (boot-parameters-store-directory-prefix params))
+            (old-entries (map boot-parameters->menu-entry rest))
+            (bootloader (operating-system-bootloader
+                          (machine-operating-system machine)))
+            (generate-bootloader-configuration-file
+             (bootloader-configuration-file-generator
+               (bootloader-configuration-bootloader bootloader))))
+       (mbegin %store-monad
+         (lower-object (generate-bootloader-configuration-file
+                         bootloader entries
+                         #:locale locale
+                         #:store-crypto-devices crypto-dev
+                         #:store-directory-prefix store-dir
+                         #:old-entries old-entries)))
+       (mlet %store-monad
+           ((remote-result (machine-remote-eval machine remote-exp)))
+         (when (eqv? 'error remote-result)
+           (raise roll-back-failure)))))
+    (_ (raise roll-back-failure))))
 
 \f
 ;;;
-- 
2.45.2

[bug#75010] [PATCH 3/7] gnu: machine: ssh: Return monadic value from roll-back-managed-host.

[Herman Rimm via Guix-patches via]

* gnu/machine/ssh.scm (roll-back-managed-host): Use return.

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

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 24c36a1936..c76b51c757 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -612,9 +612,9 @@ (define (roll-back-managed-host machine)
                          #:old-entries old-entries)))
        (mlet %store-monad
            ((remote-result (machine-remote-eval machine remote-exp)))
-         (when (eqv? 'error remote-result)
-           (raise roll-back-failure)))))
-    (_ (raise roll-back-failure))))
+         (mwhen (eqv? 'error remote-result)
+           (return (raise roll-back-failure))))))
+    (_ (return (raise roll-back-failure)))))
 
 \f
 ;;;
-- 
2.45.2

[bug#75010] [PATCH 4/7] Rename two remote variables confusingly named 'generations'.

[Herman Rimm via Guix-patches via]

From: Felix Lechner <felix.lechner@lease-up.com>

Both refer to data sets returned from the remote expression, and one of them
shadowed an element of itself.

* gnu/machine/ssh.scm (machine-boot-parameters): Rename generations
  to remote-results.

Change-Id: Ibd8a3036126d9da1215cfc191884c0f54df637df
---
 gnu/machine/ssh.scm | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index c76b51c757..3e69d4b9a3 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -455,10 +455,11 @@ (define (machine-boot-parameters machine)
                            (read-file boot-parameters-path))))
                  (reverse (generation-numbers %system-profile)))))))
 
-  (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
+  (mlet %store-monad
+      ((remote-results (machine-remote-eval machine remote-exp)))
     (return
-     (map (lambda (generation)
-            (match generation
+     (map (lambda (remote-result)
+            (match remote-result
               ((generation system-path time serialized-params)
                (let* ((params (call-with-input-string serialized-params
                                 read-boot-parameters))
@@ -477,7 +478,7 @@ (define (machine-boot-parameters machine)
                   (kernel-arguments
                    (append (bootable-kernel-arguments system-path root version)
                            (boot-parameters-kernel-arguments params))))))))
-          generations))))
+          remote-results))))
 
 (define-syntax-rule (with-roll-back should-roll-back? mbody ...)
   "Catch exceptions that arise when binding MBODY, a monadic expression in
-- 
2.45.2

[bug#75010] [PATCH 5/7] gnu: machine: Remove &deploy-error.

[Herman Rimm via Guix-patches via]

* gnu/machine.scm (&deploy-error): Remove.
* gnu/machine/ssh.scm (with-roll-back): Remove.
(deploy-managed-host): Remove with-roll-back.
* guix/scripts/deploy.scm (deploy-machine*): Remove deploy-error? case.

Change-Id: I719eafda0f5d12e1f4e3795631e78378f5376745
---
 gnu/machine.scm         | 17 +-------------
 gnu/machine/ssh.scm     | 51 +++++++++++++++--------------------------
 guix/scripts/deploy.scm |  8 +------
 3 files changed, 20 insertions(+), 56 deletions(-)

diff --git a/gnu/machine.scm b/gnu/machine.scm
index 60be674972..ede595d053 100644
--- a/gnu/machine.scm
+++ b/gnu/machine.scm
@@ -41,12 +41,7 @@ (define-module (gnu machine)
 
             deploy-machine
             roll-back-machine
-            machine-remote-eval
-
-            &deploy-error
-            deploy-error?
-            deploy-error-should-roll-back
-            deploy-error-captured-args))
+            machine-remote-eval))
 
 ;;; Commentary:
 ;;;
@@ -122,13 +117,3 @@ (define (roll-back-machine machine)
 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 3e69d4b9a3..b954620b69 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -480,18 +480,6 @@ (define (machine-boot-parameters machine)
                            (boot-parameters-kernel-arguments params))))))))
           remote-results))))
 
-(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."
@@ -536,32 +524,29 @@ (define (deploy-managed-host machine)
                         store)))))
 
         (mbegin %store-monad
-          (with-roll-back #f
-            (switch-to-system (eval/error-handling c
-                                (raise (formatted-message
-                                        (G_ "\
+          (switch-to-system (eval/error-handling c
+                              (raise (formatted-message
+                                      (G_ "\
 failed to switch systems while deploying '~a':~%~{~s ~}")
-                                        host
-                                        (inferior-exception-arguments c))))
-                              os))
+                                      host
+                                      (inferior-exception-arguments c))))
+                            os)
           (parameterize ((%current-system system)
                          (%current-target-system #f))
-            (with-roll-back #t
-              (mbegin %store-monad
-                (upgrade-shepherd-services (eval/error-handling c
-                                             (warning (G_ "\
+            (mbegin %store-monad
+              (upgrade-shepherd-services
+                (eval/error-handling c
+                  (warning (G_ "\
 an error occurred while upgrading services on '~a':~%~{~s ~}~%")
-                                                      host
-                                                      (inferior-exception-arguments
-                                                       c)))
-                                           os)
-                (install-bootloader (eval/error-handling c
-                                      (raise (formatted-message
-                                              (G_ "\
+                           host (inferior-exception-arguments c)))
+                os)
+              (install-bootloader
+                (eval/error-handling c
+                  (raise (formatted-message
+                           (G_ "\
 failed to install bootloader on '~a':~%~{~s ~}~%")
-                                              host
-                                              (inferior-exception-arguments c))))
-                                    bootloader-configuration bootcfg)))))))))
+                           host (inferior-exception-arguments c))))
+                bootloader-configuration bootcfg))))))))
 
 \f
 ;;;
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 4b1a603049..ca0e1c4023 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -156,13 +156,7 @@ (define (deploy-machine* store machine)
                    (apply format #f
                           (gettext (formatted-message-string c)
                                    %gettext-domain)
-                          (formatted-message-arguments 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))))
+                          (formatted-message-arguments c)))))
       (run-with-store store (deploy-machine machine))
 
     (info (G_ "successfully deployed ~a~%")
-- 
2.45.2

[bug#75010] [PATCH 6/7] gnu: machine: ssh: Roll-back on failure.

[Herman Rimm via Guix-patches via]

This restores the roll-back behaviour which was disabled in 2885c35.

* gnu/machine/ssh.scm (deploy-managed-host): Use roll-back-machine.

Change-Id: I8636347541ee1e4e30da15dd43455329a46c3bdb
---
 gnu/machine/ssh.scm | 15 +++++++++++----
 1 file changed, 11 insertions(+), 4 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index b954620b69..9cc9c8f099 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -512,7 +512,8 @@ (define (deploy-managed-host machine)
              (menu-entries (map boot-parameters->menu-entry boot-parameters))
              (bootloader-configuration (operating-system-bootloader os))
              (bootcfg (operating-system-bootcfg os menu-entries)))
-        (define-syntax-rule (eval/error-handling condition handler ...)
+        (define-syntax-rule (eval/error-handling condition store
+                                                 handler ...)
           ;; Return a wrapper around EVAL such that HANDLER is evaluated if an
           ;; exception is raised.
           (lambda (exp)
@@ -524,7 +525,7 @@ (define (deploy-managed-host machine)
                         store)))))
 
         (mbegin %store-monad
-          (switch-to-system (eval/error-handling c
+          (switch-to-system (eval/error-handling c store
                               (raise (formatted-message
                                       (G_ "\
 failed to switch systems while deploying '~a':~%~{~s ~}")
@@ -535,13 +536,19 @@ (define (deploy-managed-host machine)
                          (%current-target-system #f))
             (mbegin %store-monad
               (upgrade-shepherd-services
-                (eval/error-handling c
+                (eval/error-handling c store
+                  (info (G_ "rolling back ~a...~%") host)
+                  (run-with-store store (roll-back-machine machine)
+                                  #:system system)
                   (warning (G_ "\
 an error occurred while upgrading services on '~a':~%~{~s ~}~%")
                            host (inferior-exception-arguments c)))
                 os)
               (install-bootloader
-                (eval/error-handling c
+                (eval/error-handling c store
+                  (info (G_ "rolling back ~a...~%") host)
+                  (run-with-store store (roll-back-machine machine)
+                                  #:system system)
                   (raise (formatted-message
                            (G_ "\
 failed to install bootloader on '~a':~%~{~s ~}~%")
-- 
2.45.2

[bug#75010] [PATCH 7/7] WIP: gnu: tests: Add module for guix deploy tests.

[Herman Rimm via Guix-patches via]

* gnu/tests/deploy.scm: Add file.

Change-Id: I348c8bf2e518ec6c00af126993eaca3fcd453901
---
 gnu/tests/deploy.scm | 203 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 203 insertions(+)
 create mode 100644 gnu/tests/deploy.scm

diff --git a/gnu/tests/deploy.scm b/gnu/tests/deploy.scm
new file mode 100644
index 0000000000..24671cddec
--- /dev/null
+++ b/gnu/tests/deploy.scm
@@ -0,0 +1,203 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
+;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu tests deploy)
+  #:use-module (gnu packages gnupg)
+  #:use-module ((guix self) #:select (make-config.scm))
+  #:use-module (gnu services)
+  #:use-module (gnu services base)
+  #:use-module (gnu services ssh)
+  #:use-module (gnu system)
+  #:use-module (gnu system vm)
+  #:use-module (gnu tests)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (ice-9 match)
+  #:export (%test-deploy
+            %test-rollback))
+
+;;; Commentary:
+;;;
+;;; Test in-place system deployment: advancing the system generation on
+;;; a running instance of the Guix System.
+;;;
+;;; Code:
+
+(define (machines os)
+  (program-file "machines.scm"
+    #~(list (machine (configuration
+                      (machine-ssh-configuration
+                        (host-name "localhost")
+                        (system (%current-system))))
+                     (environment managed-host-environment-type)
+                     (operating-system #$os)))))
+
+(define not-config?
+  ;; Select (guix …) and (gnu …) modules, except (guix config).
+  (match-lambda
+    (('guix 'config) #f)
+    (('guix rest ...) #t)
+    (('gnu rest ...) #t)
+    (_ #f)))
+
+(define* (deploy-program #:optional (os #~%simple-os))
+  (program-file "deploy.scm"
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules `(,@(source-module-closure
+                                  '((guix scripts deploy))
+                                  #:select? not-config?)
+                               ((guix config) => ,(make-config.scm)))
+        #~(begin
+            (use-modules (guix scripts deploy))
+            (guix-deploy #$(machines os)))))))
+
+(define os
+  (marionette-operating-system
+    (simple-operating-system
+      (service openssh-service-type
+        (openssh-configuration
+          (permit-root-login #t)
+          (allow-empty-passwords? #t)))
+      (service static-networking-service-type
+        (list (static-networking
+                (inherit %loopback-static-networking)
+                (provision '(networking))))))
+    #:imported-modules '((gnu services herd)
+                         (guix combinators))))
+
+(define vm (virtual-machine os))
+
+(define* (run-deploy-test)
+  "Run a test of an OS running DEPLOY-PROGRAM, which creates a new
+generation of the system profile."
+  (define (test script)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          ;; Return the names of the generation symlinks on MARIONETTE.
+          (define (system-generations marionette)
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 ftw)
+                             (srfi srfi-1))
+                (let* ((profile-dir "/var/guix/profiles/")
+                       (entries (map first (cddr (file-system-tree profile-dir)))))
+                  (remove (lambda (entry)
+                            (member entry '("per-user" "system")))
+                          entries)))
+             marionette))
+
+          (test-runner-current (system-test-runner #$output))
+          (test-begin "deploy")
+
+          (let ((generations-prior (system-generations marionette)))
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$script)
+               marionette))
+
+            (test-equal "script created new generation"
+              (length (system-generations marionette))
+              (1+ (length generations-prior)))
+
+            (test-equal "script activated the new generation"
+              (string-append "/var/guix/profiles/system-"
+                             (number->string (+ 1 (length generations-prior)))
+                             "-link")
+              (marionette-eval '(readlink "/run/current-system")
+                               marionette)))
+
+          (test-end))))
+
+  (gexp->derivation "deploy" (test (deploy-program))))
+
+(define* (run-rollback-test)
+  "Run a test of an OS with a faulty bootloader running DEPLOY-PROGRAM,
+which causes a rollback."
+  (define os
+    #~(operating-system
+        (inherit %simple-os)
+        (bootloader
+         (bootloader-configuration
+           (inherit (operating-system-bootloader
+                      %simple-os))
+           (targets '("/dev/null"))))))
+
+  (define (test script)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          ;; Return the names of the generation symlinks on MARIONETTE.
+          (define (system-generations marionette)
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 ftw)
+                             (srfi srfi-1))
+                (let* ((profile-dir "/var/guix/profiles/")
+                       (entries (map first (cddr (file-system-tree profile-dir)))))
+                  (remove (lambda (entry)
+                            (member entry '("per-user" "system")))
+                          entries)))
+             marionette))
+
+          (test-runner-current (system-test-runner #$output))
+          (test-begin "rollback")
+
+          (let ((generations-prior (system-generations marionette)))
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$script)
+               marionette))
+
+            (test-equal "script created new generation"
+              (length (system-generations marionette))
+              (1+ (length generations-prior)))
+
+            (test-equal "script rolled back the new generation"
+              (string-append "/var/guix/profiles/system-"
+                             (number->string (length generations-prior))
+                             "-link")
+              (marionette-eval '(readlink "/run/current-system")
+                               marionette)))
+
+          (test-end))))
+
+  (gexp->derivation "rollback" (test (deploy-program os))))
+
+(define %test-deploy
+  (system-test
+   (name "deploy")
+   (description "Deploy to the local machine.")
+   (value (run-deploy-test))))
+
+(define %test-rollback
+  (system-test
+   (name "rollback")
+   (description "Rollback the deployment of a faulty bootloader.")
+   (value (run-rollback-test))))
-- 
2.45.2