[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

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

[Ludovic Courtès]

Hi,

Herman Rimm <herman@rimm.ee> skribis:

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

[...]

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

The (mbegin …) expression has no effect because it’s not in tail
position (it expands to (lambda (…) …)).

Even if it had an effect, generating the bootloader config file in
itself does nothing: it has to at least be copied to the right place or
passed as an argument to ‘grub-install’ or similar.

The following ‘mlet’ should use ‘mwhen’ rather than ‘when’ to return a
monadic value when the condition is false.

These two bugs are actually already present in ‘master’, so I guess
we’re dealing with untested code. 😱

(We should come up with a strategy to test those things.)

Ludo’.

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

[Ludovic Courtès]

Herman Rimm <herman@rimm.ee> skribis:

> * gnu/tests/deploy.scm: Add file.
>
> Change-Id: I348c8bf2e518ec6c00af126993eaca3fcd453901

Yay, nice!

Could you add it to ‘gnu/local.mk’?

> +(define (machines os)
> +  (program-file "machines.scm"
> +    #~(list (machine (configuration

This should be ‘scheme-file’ (with normal indentation).

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

We could use the ‘guix’ package here: it would be faster, but then we
would be testing an older snapshot and not the code at hand.  Not great.

Still, maybe using ‘current-guix’ would be faster (fewer things to
build), as in:

  #~(execl #$(file-append (current-guix) "/bin/guix")
           "guix" "deploy“ #$(machines os))

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

Please use ‘match’ rather than ‘first’ and ‘cddr’ (info "(guix) Data
Types and Pattern Matching").

Or maybe you could just as well use ‘scandir’?

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

We could also check other things, like the host name.

Ludo’.

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

[Ludovic Courtès]

Herman Rimm <herman@rimm.ee> skribis:

> * doc/guix.texi (The Store Monad): Document mmatch.
> * guix/monads.scm (mmatch): Add macro.
>
> Change-Id: I558f8e025f6cf788c9fc475e99d49690d7a98f41

[...]

> +@defmac mmatch monad mexp (pattern body) @dots{}
> +Match monadic object @var{mexp} against clause @var{pattern}s, in the

I’m not convinced by this one: usually, monadic procedures take a
“normal” value and return a monadic value.  So the style of this macro
is quite unusual.  Also it doesn’t save much typing compared to an
‘mlet’ followed by ‘match’.

WDYT?

Ludo’.

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

[Ludovic Courtès]

Herman Rimm <herman@rimm.ee> skribis:

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

[...]

> -    (_ (raise roll-back-failure))))
> +         (mwhen (eqv? 'error remote-result)
> +           (return (raise roll-back-failure))))))
> +    (_ (return (raise roll-back-failure)))))

Definitely.  :-)

(‘return’ could be omitted since it won’t return.)

Ludo’.