GNU bug report logs - #75010
[PATCH 0/7] Roll back when deployment fails.

Previous Next

Full log

View this message in rfc822 format

From: Herman Rimm <herman <at> rimm.ee>
To: 75010 <at> debbugs.gnu.org
Subject: [bug#75010] [PATCH v4 1/5] gnu: machine: ssh: Refactor roll-back-managed-host.
Date: Fri,  9 May 2025 08:02:25 +0200

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

Change-Id: Ic3d5039ecf01e1e965dce8a696e7dbd625d2b3c5
---
 gnu/machine/ssh.scm | 57 +++++++++++++++++++++++----------------------
 1 file changed, 29 insertions(+), 28 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 73d5dc513ee..696b349a303 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -3,6 +3,8 @@
 ;;; Copyright © 2020-2024 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2024 Ricardo <rekado <at> elephly.net>
 ;;; Copyright © 2025 Arun Isaac <arunisaac <at> systemreboot.net>
+;;; Copyright © 2024 Felix Lechner <felix.lechner <at> lease-up.com>
+;;; Copyright © 2025 Herman Rimm <herman <at> rimm.ee>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -597,34 +599,33 @@ (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)))
-    (if (eqv? 'error remote-result)
-        (raise roll-back-failure)
-        (return remote-result))))
+  (mlet %store-monad
+      ((boot-parameters (machine-boot-parameters machine)))
+    (match boot-parameters
+      ((_ 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)))
+           (if (eqv? 'error remote-result)
+               (raise roll-back-failure)
+               (return remote-result)))))
+      (_ (raise roll-back-failure)))))
 
 
 ;;;
-- 
2.48.1

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.