Package: guix-patches;
Reported by: Herman Rimm <herman <at> rimm.ee>
Date: Sat, 21 Dec 2024 17:04:02 UTC
Severity: normal
Tags: moreinfo, patch
To reply to this bug, email your comments to 75010 AT debbugs.gnu.org.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Sat, 21 Dec 2024 17:04:02 GMT) Full text and rfc822 format available.Herman Rimm <herman <at> rimm.ee>:guix-patches <at> gnu.org.
(Sat, 21 Dec 2024 17:04:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: guix-patches <at> gnu.org Subject: [PATCH 0/7] Roll back when deployment fails. Date: Sat, 21 Dec 2024 18:02:35 +0100
[Message part 1 (text/plain, inline)]
Hello, Felix's patch is from issue #69343, one is also squashed into [PATCH 2/7]. In [PATCH 2/7], does the mbegin above the mlet work, or is its value discarded? Guix deploy seems to work the same way. In [PATCH 7/7] I try to add a test for the guix deploy rollback behavior. See attachment, why does this error occur? Cheers, Herman Felix Lechner (1): Rename two remote variables confusingly named 'generations'. Herman Rimm (6): monads: Add 'mmatch'. gnu: machine: ssh: Refactor roll-back-managed-host. gnu: machine: ssh: Return monadic value from roll-back-managed-host. gnu: machine: Remove &deploy-error. gnu: machine: ssh: Roll-back on failure. WIP: gnu: tests: Add module for guix deploy tests. doc/guix.texi | 6 ++ gnu/machine.scm | 17 +--- gnu/machine/ssh.scm | 122 +++++++++++------------- gnu/tests/deploy.scm | 203 ++++++++++++++++++++++++++++++++++++++++ guix/monads.scm | 11 +++ guix/scripts/deploy.scm | 8 +- 6 files changed, 279 insertions(+), 88 deletions(-) create mode 100644 gnu/tests/deploy.scm base-commit: 11855e1c2863c56d9a3364cdac614a529a1c7cc2 -- 2.45.2
[1gv9mdpy6ygfgfvh4j56j4nq8c9a1m-module-import-compiled.drv.gz (application/x-gunzip, attachment)]
guix <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, maxim.cournoyer <at> gmail.com, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Sat, 21 Dec 2024 17:06:02 GMT) Full text and rfc822 format available.Message #8 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH 1/7] monads: Add 'mmatch'. Date: Sat, 21 Dec 2024 18:04:05 +0100
* 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 <at> gnu.org>
+;;; Copyright © 2024 Herman Rimm <herman <at> 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
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Sat, 21 Dec 2024 17:06:03 GMT) Full text and rfc822 format available.Message #11 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH 2/7] gnu: machine: ssh: Refactor roll-back-managed-host. Date: Sat, 21 Dec 2024 18:04:06 +0100
* 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 <at> sdf.org>
;;; Copyright © 2020-2023 Ludovic Courtès <ludo <at> gnu.org>
;;; Copyright © 2024 Ricardo <rekado <at> elephly.net>
+;;; Copyright © 2024 Felix Lechner <felix.lechner <at> lease-up.com>
+;;; Copyright © 2024 Herman Rimm <herman <at> 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))))
;;;
--
2.45.2
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Sat, 21 Dec 2024 17:06:03 GMT) Full text and rfc822 format available.Message #14 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH 3/7] gnu: machine: ssh: Return monadic value from roll-back-managed-host. Date: Sat, 21 Dec 2024 18:04:07 +0100
* 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)))))
;;;
--
2.45.2
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Sat, 21 Dec 2024 17:06:04 GMT) Full text and rfc822 format available.Message #17 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Cc: Felix Lechner <felix.lechner <at> lease-up.com> Subject: [PATCH 4/7] Rename two remote variables confusingly named 'generations'. Date: Sat, 21 Dec 2024 18:04:08 +0100
From: Felix Lechner <felix.lechner <at> 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
guix <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Sat, 21 Dec 2024 17:06:04 GMT) Full text and rfc822 format available.Message #20 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH 5/7] gnu: machine: Remove &deploy-error. Date: Sat, 21 Dec 2024 18:04:09 +0100
* 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)))
-
-
-;;;
-;;; 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))))))))
;;;
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
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Sat, 21 Dec 2024 17:06:05 GMT) Full text and rfc822 format available.Message #23 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH 6/7] gnu: machine: ssh: Roll-back on failure. Date: Sat, 21 Dec 2024 18:04:10 +0100
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
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Sat, 21 Dec 2024 17:06:05 GMT) Full text and rfc822 format available.Message #26 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH 7/7] WIP: gnu: tests: Add module for guix deploy tests. Date: Sat, 21 Dec 2024 18:04:11 +0100
* 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 <at> sdf.org>
+;;; Copyright © 2024 Herman Rimm <herman <at> 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
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Mon, 30 Dec 2024 12:10:02 GMT) Full text and rfc822 format available.Message #29 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Herman Rimm <herman <at> rimm.ee> Cc: 75010 <at> debbugs.gnu.org Subject: Re: [bug#75010] [PATCH 2/7] gnu: machine: ssh: Refactor roll-back-managed-host. Date: Mon, 30 Dec 2024 13:09:04 +0100
Hi, Herman Rimm <herman <at> 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’.
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Mon, 30 Dec 2024 12:22:01 GMT) Full text and rfc822 format available.Message #32 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Herman Rimm <herman <at> rimm.ee> Cc: 75010 <at> debbugs.gnu.org Subject: Re: [bug#75010] [PATCH 7/7] WIP: gnu: tests: Add module for guix deploy tests. Date: Mon, 30 Dec 2024 13:21:12 +0100
Herman Rimm <herman <at> 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’.
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Mon, 30 Dec 2024 12:35:02 GMT) Full text and rfc822 format available.Message #35 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Herman Rimm <herman <at> rimm.ee> Cc: Josselin Poiret <dev <at> jpoiret.xyz>, Maxim Cournoyer <maxim.cournoyer <at> gmail.com>, Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr>, 75010 <at> debbugs.gnu.org, Christopher Baines <guix <at> cbaines.net> Subject: Re: [bug#75010] [PATCH 1/7] monads: Add 'mmatch'. Date: Mon, 30 Dec 2024 13:34:19 +0100
Herman Rimm <herman <at> 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’.
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Mon, 30 Dec 2024 12:38:02 GMT) Full text and rfc822 format available.Message #38 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Herman Rimm <herman <at> rimm.ee> Cc: 75010 <at> debbugs.gnu.org Subject: Re: [bug#75010] [PATCH 3/7] gnu: machine: ssh: Return monadic value from roll-back-managed-host. Date: Mon, 30 Dec 2024 13:36:40 +0100
Herman Rimm <herman <at> 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’.
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Fri, 31 Jan 2025 11:15:02 GMT) Full text and rfc822 format available.Message #41 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: Ludovic Courtès <ludo <at> gnu.org> Cc: 75010 <at> debbugs.gnu.org Subject: [PATCH v2 0/2] Add module for guix deploy tests. Date: Fri, 31 Jan 2025 12:13:15 +0100
[Message part 1 (text/plain, inline)]
Hi Ludo', Thanks for your feedback. I'm not sure how to fix the bugs in guix deploy. For now I want to make the tests for guix deploy work, so I only submit [PATCH v2 1/2], previously [PATCH 7/7]. [PATCH v2 2/2] has workarounds, the one in (gnu packages file-systems) is because I don't know how to get the deploy tests to load e.g. (guix platforms x86). I run these commands: guix shell -D guix gnupg -CPWN make ./pre-inst-env guix build -f test.scm &> result I attached result, test.scm contains: (use-modules (gnu tests deploy) (gnu tests reconfigure)) ;%test-rollback %test-deploy ;%test-switch-to-system %test-deploy runs into an error I don't know how to fix or work around. Cheers, Herman Herman Rimm (2): gnu: tests: Add module for guix deploy tests. Fix deploy test errors. gnu/local.mk | 3 +- gnu/packages/file-systems.scm | 4 +- gnu/tests/deploy.scm | 224 ++++++++++++++++++++++++++++++++++ guix/channels.scm | 3 +- 4 files changed, 228 insertions(+), 6 deletions(-) create mode 100644 gnu/tests/deploy.scm base-commit: 5a6c66f7919fbe79251cd425ae6952e67acbe94c -- 2.47.1
[result (text/plain, attachment)]
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Fri, 31 Jan 2025 11:16:01 GMT) Full text and rfc822 format available.Message #44 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH v2 1/2] gnu: tests: Add module for guix deploy tests. Date: Fri, 31 Jan 2025 12:14:23 +0100
* gnu/tests/deploy.scm: Add file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Register file.
Change-Id: I348c8bf2e518ec6c00af126993eaca3fcd453901
---
gnu/local.mk | 3 +-
gnu/tests/deploy.scm | 224 +++++++++++++++++++++++++++++++++++++++++++
2 files changed, 226 insertions(+), 1 deletion(-)
create mode 100644 gnu/tests/deploy.scm
diff --git a/gnu/local.mk b/gnu/local.mk
index e8c807cf630..3addd69746a 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -62,7 +62,7 @@
# Copyright © 2023 B. Wilson <elaexuotee <at> wilsonb.com>
# Copyright © 2023 Bruno Victal <mirai <at> makinata.eu>
# Copyright © 2023, 2024 gemmaro <gemmaro.dev <at> gmail.com>
-# Copyright © 2023 Herman Rimm <herman <at> rimm.ee>
+# Copyright © 2023, 2025 Herman Rimm <herman <at> rimm.ee>
# Copyright © 2023 Troy Figiel <troy <at> troyfigiel.com>
# Copyright © 2024, 2025 David Elsing <david.elsing <at> posteo.net>
# Copyright © 2024 Ashish SHUKLA <ashish.is <at> lostca.se>
@@ -840,6 +840,7 @@ GNU_SYSTEM_MODULES = \
%D%/tests/containers.scm \
%D%/tests/cups.scm \
%D%/tests/databases.scm \
+ %D%/tests/deploy.scm \
%D%/tests/desktop.scm \
%D%/tests/dns.scm \
%D%/tests/dict.scm \
diff --git a/gnu/tests/deploy.scm b/gnu/tests/deploy.scm
new file mode 100644
index 00000000000..96f074d1f90
--- /dev/null
+++ b/gnu/tests/deploy.scm
@@ -0,0 +1,224 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays <at> sdf.org>
+;;; Copyright © 2024 Herman Rimm <herman <at> 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 (gnu packages package-management)
+ #:use-module (gnu packages ssh)
+ #: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)
+ (scheme-file
+ "machines.scm"
+ #~(begin (use-modules (gnu machine ssh)
+ (guix utils)
+ (ice-9 ftw)
+ (ssh key))
+ ;; XXX: (guix platforms ...) are not found in %load-path.
+ (set! (@ (guix platform) systems)
+ (compose list %current-system))
+ (list (machine
+ (configuration
+ (machine-ssh-configuration
+ (host-name "localhost")
+ (host-key
+ (string-append
+ "ssh-ed25519 "
+ (public-key->string
+ (public-key-from-file
+ "/etc/ssh/ssh_host_ed25519_key.pub"))))
+ (system (%current-system))))
+ (environment managed-host-environment-type)
+ ;; XXX: First S-expression is for operating-system.
+ (operating-system
+ (call-with-input-file
+ "/run/current-system/configuration.scm"
+ read)))))))
+
+(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 guile-ssh)
+ (with-imported-modules
+ `(((guix config) => ,(make-config.scm)))
+ #~(execl #$(file-append (current-guix) "/bin/guix")
+ "guix" "deploy" #$(machines os))))))
+
+(define os
+ (marionette-operating-system
+ (operating-system-with-provenance
+ (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 system-generations-definition
+ #~(define (system-generations marionette)
+ "Return the names of the generation symlinks on MARIONETTE."
+ (marionette-eval
+ '(begin (use-modules (ice-9 ftw))
+ (define (select? entry)
+ (not (member entry '("per-user" "system" "." ".."))))
+ (scandir "/var/guix/profiles/" select?))
+ marionette)))
+
+(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)
+ (ice-9 match)
+ (srfi srfi-64))
+
+ (define marionette
+ (make-marionette (list #$vm)))
+
+ #$system-generations-definition
+
+ (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-assert "uname"
+ (match (marionette-eval '(uname) marionette)
+ (#("Linux" host-name _ ...)
+ (string=? host-name #$(operating-system-host-name os)))))
+
+ (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 new-os
+ #~(operating-system
+ (inherit %simple-os)
+ (host-name (substring (operating-system-host-name %simple-os)
+ 0 1))
+ (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)
+ (ice-9 match)
+ (srfi srfi-64))
+
+ (define marionette
+ (make-marionette (list #$vm)))
+
+ #$system-generations-definition
+
+ (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-assert "uname"
+ (match (marionette-eval '(uname) marionette)
+ (#("Linux" host-name _ ...)
+ (string=? host-name #$(operating-system-host-name os)))))
+
+ (test-end))))
+
+ (gexp->derivation "rollback" (test (deploy-program new-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.47.1
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Fri, 31 Jan 2025 11:16:02 GMT) Full text and rfc822 format available.Message #47 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH v2 2/2] Fix deploy test errors. Date: Fri, 31 Jan 2025 12:14:24 +0100
Change-Id: I5e321124cade4ce46209688c94b7c340940fce21
---
gnu/packages/file-systems.scm | 4 +---
guix/channels.scm | 3 +--
2 files changed, 2 insertions(+), 5 deletions(-)
diff --git a/gnu/packages/file-systems.scm b/gnu/packages/file-systems.scm
index 5fd92d08fb1..c66642bb39a 100644
--- a/gnu/packages/file-systems.scm
+++ b/gnu/packages/file-systems.scm
@@ -601,9 +601,7 @@ (define-public gphotofs
(license license:gpl2+)))
(define bcachefs-tools-rust-target
- (platform-rust-target (lookup-platform-by-target-or-system
- (or (%current-target-system)
- (%current-system)))))
+ "x86_64-unknown-linux-gnu")
(define bcachefs-tools-target/release
(string-append "target/" bcachefs-tools-rust-target "/release"))
diff --git a/guix/channels.scm b/guix/channels.scm
index 4700f7a45d0..d6425a31dfb 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -565,8 +565,7 @@ (define* (latest-channel-instances store channels
(let* ((current (current-commit (channel-name channel)))
(instance
(latest-channel-instance store channel
- #:authenticate?
- authenticate?
+ #:authenticate? #f
#:validate-pull
validate-pull
#:starting-commit
--
2.47.1
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Sun, 09 Feb 2025 16:32:01 GMT) Full text and rfc822 format available.Message #50 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Herman Rimm <herman <at> rimm.ee> Cc: 75010 <at> debbugs.gnu.org Subject: Re: [bug#75010] [PATCH v2 1/2] gnu: tests: Add module for guix deploy tests. Date: Sun, 09 Feb 2025 17:31:32 +0100
Herman Rimm <herman <at> rimm.ee> skribis:
> * gnu/tests/deploy.scm: Add file.
> * gnu/local.mk (GNU_SYSTEM_MODULES): Register file.
>
> Change-Id: I348c8bf2e518ec6c00af126993eaca3fcd453901
Nice!
[...]
> +(define (machines os)
Unless I’m mistaken, ‘os’ is actually unused. I’d suggest making ‘os’
an sexp and actually using it instead of reading
/run/current-system/configuration.scm.
The OS to deploy should be different from the one already running (at
least a different host name, etc.) as a way to ensure that an actual
deployment occurs.
So you should probably have:
(define target-os-source
'(begin
(use-modules (gnu))
…
(operating-system
…)))
(This is similar to uses of ‘define-os-with-source’ in other tests
except that we probably only need the source in this case.)
> + (scheme-file
> + "machines.scm"
> + #~(begin (use-modules (gnu machine ssh)
Please indent the usual way:
(scheme-file "machines.scm"
#~(begin
(use-modules …)
…))
> + ;; XXX: (guix platforms ...) are not found in %load-path.
> + (set! (@ (guix platform) systems)
> + (compose list %current-system))
What’s the problem here?
> + (machine-ssh-configuration
> + (host-name "localhost")
> + (host-key
> + (string-append
> + "ssh-ed25519 "
> + (public-key->string
> + (public-key-from-file
> + "/etc/ssh/ssh_host_ed25519_key.pub"))))
It’s enough to do:
(call-with-input-file "/etc/ssh/ssh_host_ed25519_key.pub"
get-string-all)
> +(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))))
For clarity, I’d change ‘name’ of the 2nd one to "deploy-rollback" and
clarify in the description that this is about ‘guix deploy’.
Could you send an updated version?
Thanks,
Ludo’.
Ludovic Courtès <ludo <at> gnu.org>
to control <at> debbugs.gnu.org.
(Tue, 18 Feb 2025 16:56:02 GMT) Full text and rfc822 format available.guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Wed, 30 Apr 2025 13:29:02 GMT) Full text and rfc822 format available.Message #55 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH v3 2/2] Fix deploy test errors. Date: Wed, 30 Apr 2025 15:05:28 +0200
Change-Id: I5e321124cade4ce46209688c94b7c340940fce21
---
gnu/packages/file-systems.scm | 4 +---
guix/channels.scm | 3 +--
2 files changed, 2 insertions(+), 5 deletions(-)
diff --git a/gnu/packages/file-systems.scm b/gnu/packages/file-systems.scm
index b7ebf61beb0..3242a2dcdeb 100644
--- a/gnu/packages/file-systems.scm
+++ b/gnu/packages/file-systems.scm
@@ -713,9 +713,7 @@ (define-public gphotofs
(license license:gpl2+)))
(define bcachefs-tools-rust-target
- (platform-rust-target (lookup-platform-by-target-or-system
- (or (%current-target-system)
- (%current-system)))))
+ "x86_64-unknown-linux-gnu")
(define bcachefs-tools-target/release
(string-append "target/" bcachefs-tools-rust-target "/release"))
diff --git a/guix/channels.scm b/guix/channels.scm
index 4700f7a45d0..d6425a31dfb 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -565,8 +565,7 @@ (define* (latest-channel-instances store channels
(let* ((current (current-commit (channel-name channel)))
(instance
(latest-channel-instance store channel
- #:authenticate?
- authenticate?
+ #:authenticate? #f
#:validate-pull
validate-pull
#:starting-commit
--
2.48.1
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Wed, 30 Apr 2025 13:29:02 GMT) Full text and rfc822 format available.Message #58 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH v3 1/2] gnu: tests: Add module for guix deploy tests. Date: Wed, 30 Apr 2025 15:05:27 +0200
* gnu/tests/deploy.scm: Add file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Register file.
Change-Id: I348c8bf2e518ec6c00af126993eaca3fcd453901
---
gnu/local.mk | 3 +-
gnu/tests/deploy.scm | 223 +++++++++++++++++++++++++++++++++++++++++++
2 files changed, 225 insertions(+), 1 deletion(-)
create mode 100644 gnu/tests/deploy.scm
diff --git a/gnu/local.mk b/gnu/local.mk
index adbb893a419..a100bfb0aa2 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -62,7 +62,7 @@
# Copyright © 2023 B. Wilson <elaexuotee <at> wilsonb.com>
# Copyright © 2023 Bruno Victal <mirai <at> makinata.eu>
# Copyright © 2023, 2024 gemmaro <gemmaro.dev <at> gmail.com>
-# Copyright © 2023 Herman Rimm <herman <at> rimm.ee>
+# Copyright © 2023, 2025 Herman Rimm <herman <at> rimm.ee>
# Copyright © 2023 Troy Figiel <troy <at> troyfigiel.com>
# Copyright © 2024, 2025 David Elsing <david.elsing <at> posteo.net>
# Copyright © 2024 Ashish SHUKLA <ashish.is <at> lostca.se>
@@ -847,6 +847,7 @@ GNU_SYSTEM_MODULES = \
%D%/tests/containers.scm \
%D%/tests/cups.scm \
%D%/tests/databases.scm \
+ %D%/tests/deploy.scm \
%D%/tests/desktop.scm \
%D%/tests/dns.scm \
%D%/tests/dict.scm \
diff --git a/gnu/tests/deploy.scm b/gnu/tests/deploy.scm
new file mode 100644
index 00000000000..55d3edb78ef
--- /dev/null
+++ b/gnu/tests/deploy.scm
@@ -0,0 +1,223 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays <at> sdf.org>
+;;; Copyright © 2024, 2025 Herman Rimm <herman <at> 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 (gnu packages package-management)
+ #:use-module (gnu packages ssh)
+ #: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-source)
+ (scheme-file "machines.scm"
+ #~(begin (use-modules (gnu machine ssh)
+ (guix utils)
+ (ice-9 textual-ports))
+ ;; XXX: (guix platforms ...) are not found in %load-path.
+ (set! (@ (guix platform) systems)
+ (compose list %current-system))
+ (list (machine
+ (configuration
+ (machine-ssh-configuration
+ (host-name "localhost")
+ (host-key
+ (call-with-input-file "/etc/ssh/ssh_host_ed25519_key.pub"
+ get-string-all))
+ (system (%current-system))))
+ (environment managed-host-environment-type)
+ (operating-system #$os-source))))))
+
+(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 os-source)
+ (program-file "deploy.scm"
+ (with-extensions (list guile-gcrypt guile-ssh)
+ (with-imported-modules
+ `(((guix config) => ,(make-config.scm)))
+ #~(execl #$(file-append (current-guix) "/bin/guix")
+ "guix" "deploy" #$(machines os-source))))))
+
+(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 system-generations-definition
+ #~(define (system-generations marionette)
+ "Return the names of the generation symlinks on MARIONETTE."
+ (marionette-eval
+ '(begin (use-modules (ice-9 ftw))
+ (define (select? entry)
+ (not (member entry '("per-user" "system" "." ".."))))
+ (scandir "/var/guix/profiles/" select?))
+ marionette)))
+
+(define* (run-deploy-test)
+ "Run a test of an OS running DEPLOY-PROGRAM, which creates a new
+generation of the system profile."
+ (define new-os-source
+ '(begin
+ (use-modules (gnu tests))
+ (operating-system
+ (inherit %simple-os)
+ (host-name (substring (operating-system-host-name %simple-os)
+ 0 1)))))
+
+ (define (test script)
+ (with-imported-modules '((gnu build marionette))
+ #~(begin
+ (use-modules (gnu build marionette)
+ (ice-9 match)
+ (srfi srfi-64))
+
+ (define marionette
+ (make-marionette (list #$vm)))
+
+ #$system-generations-definition
+
+ (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-assert "uname"
+ (match (marionette-eval '(uname) marionette)
+ (#("Linux" host-name _ ...)
+ (string=? host-name #$(operating-system-host-name os)))))
+
+ (test-end))))
+
+ (gexp->derivation "deploy" (test (deploy-program new-os-source))))
+
+(define* (run-rollback-test)
+ "Run a test of an OS with a faulty bootloader running DEPLOY-PROGRAM,
+which causes a rollback."
+ (define bad-os-source
+ '(begin
+ (use-modules (gnu tests))
+ (operating-system
+ (inherit %simple-os)
+ (host-name (substring (operating-system-host-name %simple-os)
+ 0 1))
+ (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)
+ (ice-9 match)
+ (srfi srfi-64))
+
+ (define marionette
+ (make-marionette (list #$vm)))
+
+ #$system-generations-definition
+
+ (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-assert "uname"
+ (match (marionette-eval '(uname) marionette)
+ (#("Linux" host-name _ ...)
+ (string=? host-name #$(operating-system-host-name os)))))
+
+ (test-end))))
+
+ (gexp->derivation "rollback" (test (deploy-program bad-os-source))))
+
+(define %test-deploy
+ (system-test
+ (name "deploy")
+ (description "Deploy to the local machine.")
+ (value (run-deploy-test))))
+
+(define %test-rollback
+ (system-test
+ (name "deploy-rollback")
+ (description "Rollback guix deploy with a faulty bootloader.")
+ (value (run-rollback-test))))
--
2.48.1
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Wed, 30 Apr 2025 13:49:02 GMT) Full text and rfc822 format available.Message #61 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: Ludovic Courtès <ludo <at> gnu.org>, 75010 <at> debbugs.gnu.org Subject: Re: [bug#75010] [PATCH v2 1/2] gnu: tests: Add module for guix deploy tests. Date: Wed, 30 Apr 2025 15:47:06 +0200
[Message part 1 (text/plain, inline)]
Hi, On Sun, Feb 09, 2025 at 05:31:32PM +0100, Ludovic Courtès wrote: > > + ;; XXX: (guix platforms ...) are not found in %load-path. > > + (set! (@ (guix platform) systems) > > + (compose list %current-system)) > > What’s the problem here? I attached the log I get when running %test-deploy without this code. Cheers, Herman
[result2 (text/plain, attachment)]
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Tue, 06 May 2025 10:32:02 GMT) Full text and rfc822 format available.Message #64 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Herman Rimm <herman <at> rimm.ee> Cc: 75010 <at> debbugs.gnu.org Subject: Re: [bug#75010] [PATCH v3 1/2] gnu: tests: Add module for guix deploy tests. Date: Tue, 06 May 2025 12:01:49 +0200
Hi Herman, Herman Rimm <herman <at> rimm.ee> writes: > * gnu/tests/deploy.scm: Add file. > * gnu/local.mk (GNU_SYSTEM_MODULES): Register file. > > Change-Id: I348c8bf2e518ec6c00af126993eaca3fcd453901 This patch LGTM. What about the rest of the initial series though (7 patches)? From what I can see, there are two outstanding issues on patches #1 and #2, but I didn’t get your feedback on these. Let me know what you think. Thanks, Ludo’.
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Fri, 09 May 2025 06:04:01 GMT) Full text and rfc822 format available.Message #67 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH v4 0/5] Roll back when deployment fails. Date: Fri, 9 May 2025 08:02:24 +0200
Hi, I removed [PATCH 1/7] and adjusted [PATCH 2/7], now [PATCH v4 1/5]. > 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. I do not want to fix this bug in [PATCH v4 1/5]. If it should be fixed first, I can send another [PATCH v4 1/5] revision once it is. I still do not know how to fix it. 55a5181e745131e5369beaf59d4d406da92b5617 made [PATCH 3/7] obsolete. Cheers, Herman Felix Lechner (1): Rename two remote variables confusingly named 'generations'. Herman Rimm (4): gnu: machine: ssh: Refactor roll-back-managed-host. gnu: machine: Remove &deploy-error. gnu: machine: ssh: Roll-back on failure. gnu: tests: Add module for guix deploy tests. gnu/local.mk | 3 +- gnu/machine.scm | 17 +-- gnu/machine/ssh.scm | 140 ++++++++++++------------- gnu/tests/deploy.scm | 223 ++++++++++++++++++++++++++++++++++++++++ guix/scripts/deploy.scm | 8 +- 5 files changed, 295 insertions(+), 96 deletions(-) create mode 100644 gnu/tests/deploy.scm base-commit: 2e1ead7c8b449b58d571d8f16c1586b675c13ab4 -- 2.48.1
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Fri, 09 May 2025 06:04:02 GMT) Full text and rfc822 format available.Message #70 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [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
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Fri, 09 May 2025 06:04:02 GMT) Full text and rfc822 format available.Message #73 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH v4 3/5] gnu: machine: Remove &deploy-error. Date: Fri, 9 May 2025 08:02:27 +0200
* 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 | 62 +++++++++++++++--------------------------
guix/scripts/deploy.scm | 8 +-----
3 files changed, 25 insertions(+), 62 deletions(-)
diff --git a/gnu/machine.scm b/gnu/machine.scm
index 60be6749727..ede595d053d 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)))
-
-
-;;;
-;;; 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 47f379c57e3..aea390fe0b3 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -481,18 +481,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."
@@ -537,39 +525,35 @@ (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)
- (load-system-for-kexec (eval/error-handling c
- (warning (G_ "\
+ host (inferior-exception-arguments c)))
+ os)
+ (load-system-for-kexec
+ (eval/error-handling c
+ (warning (G_ "\
failed to load system of '~a' for kexec reboot:~%~{~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))))))))
;;;
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index e2ef0006e06..f80982b6d18 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -181,13 +181,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.48.1
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Fri, 09 May 2025 06:04:03 GMT) Full text and rfc822 format available.Message #76 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Cc: Felix Lechner <felix.lechner <at> lease-up.com> Subject: [PATCH v4 2/5] Rename two remote variables confusingly named 'generations'. Date: Fri, 9 May 2025 08:02:26 +0200
From: Felix Lechner <felix.lechner <at> 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 696b349a303..47f379c57e3 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -456,10 +456,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))
@@ -478,7 +479,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.48.1
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Fri, 09 May 2025 06:04:03 GMT) Full text and rfc822 format available.Message #79 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH v4 4/5] gnu: machine: ssh: Roll-back on failure. Date: Fri, 9 May 2025 08:02:28 +0200
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 | 20 +++++++++++++++-----
1 file changed, 15 insertions(+), 5 deletions(-)
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index aea390fe0b3..357b4376d4b 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -513,7 +513,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)
@@ -525,7 +526,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 ~}")
@@ -536,19 +537,28 @@ (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)
(load-system-for-kexec
- (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_ "\
failed to load system of '~a' for kexec reboot:~%~{~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.48.1
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Fri, 09 May 2025 06:04:04 GMT) Full text and rfc822 format available.Message #82 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Subject: [PATCH v4 5/5] gnu: tests: Add module for guix deploy tests. Date: Fri, 9 May 2025 08:02:29 +0200
* gnu/tests/deploy.scm: Add file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Register file.
Change-Id: I348c8bf2e518ec6c00af126993eaca3fcd453901
---
gnu/local.mk | 3 +-
gnu/tests/deploy.scm | 223 +++++++++++++++++++++++++++++++++++++++++++
2 files changed, 225 insertions(+), 1 deletion(-)
create mode 100644 gnu/tests/deploy.scm
diff --git a/gnu/local.mk b/gnu/local.mk
index e6ece8cc483..157d327e53b 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -62,7 +62,7 @@
# Copyright © 2023 B. Wilson <elaexuotee <at> wilsonb.com>
# Copyright © 2023 Bruno Victal <mirai <at> makinata.eu>
# Copyright © 2023, 2024 gemmaro <gemmaro.dev <at> gmail.com>
-# Copyright © 2023 Herman Rimm <herman <at> rimm.ee>
+# Copyright © 2023, 2025 Herman Rimm <herman <at> rimm.ee>
# Copyright © 2023 Troy Figiel <troy <at> troyfigiel.com>
# Copyright © 2024, 2025 David Elsing <david.elsing <at> posteo.net>
# Copyright © 2024 Ashish SHUKLA <ashish.is <at> lostca.se>
@@ -847,6 +847,7 @@ GNU_SYSTEM_MODULES = \
%D%/tests/containers.scm \
%D%/tests/cups.scm \
%D%/tests/databases.scm \
+ %D%/tests/deploy.scm \
%D%/tests/desktop.scm \
%D%/tests/dns.scm \
%D%/tests/dict.scm \
diff --git a/gnu/tests/deploy.scm b/gnu/tests/deploy.scm
new file mode 100644
index 00000000000..55d3edb78ef
--- /dev/null
+++ b/gnu/tests/deploy.scm
@@ -0,0 +1,223 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays <at> sdf.org>
+;;; Copyright © 2024, 2025 Herman Rimm <herman <at> 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 (gnu packages package-management)
+ #:use-module (gnu packages ssh)
+ #: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-source)
+ (scheme-file "machines.scm"
+ #~(begin (use-modules (gnu machine ssh)
+ (guix utils)
+ (ice-9 textual-ports))
+ ;; XXX: (guix platforms ...) are not found in %load-path.
+ (set! (@ (guix platform) systems)
+ (compose list %current-system))
+ (list (machine
+ (configuration
+ (machine-ssh-configuration
+ (host-name "localhost")
+ (host-key
+ (call-with-input-file "/etc/ssh/ssh_host_ed25519_key.pub"
+ get-string-all))
+ (system (%current-system))))
+ (environment managed-host-environment-type)
+ (operating-system #$os-source))))))
+
+(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 os-source)
+ (program-file "deploy.scm"
+ (with-extensions (list guile-gcrypt guile-ssh)
+ (with-imported-modules
+ `(((guix config) => ,(make-config.scm)))
+ #~(execl #$(file-append (current-guix) "/bin/guix")
+ "guix" "deploy" #$(machines os-source))))))
+
+(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 system-generations-definition
+ #~(define (system-generations marionette)
+ "Return the names of the generation symlinks on MARIONETTE."
+ (marionette-eval
+ '(begin (use-modules (ice-9 ftw))
+ (define (select? entry)
+ (not (member entry '("per-user" "system" "." ".."))))
+ (scandir "/var/guix/profiles/" select?))
+ marionette)))
+
+(define* (run-deploy-test)
+ "Run a test of an OS running DEPLOY-PROGRAM, which creates a new
+generation of the system profile."
+ (define new-os-source
+ '(begin
+ (use-modules (gnu tests))
+ (operating-system
+ (inherit %simple-os)
+ (host-name (substring (operating-system-host-name %simple-os)
+ 0 1)))))
+
+ (define (test script)
+ (with-imported-modules '((gnu build marionette))
+ #~(begin
+ (use-modules (gnu build marionette)
+ (ice-9 match)
+ (srfi srfi-64))
+
+ (define marionette
+ (make-marionette (list #$vm)))
+
+ #$system-generations-definition
+
+ (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-assert "uname"
+ (match (marionette-eval '(uname) marionette)
+ (#("Linux" host-name _ ...)
+ (string=? host-name #$(operating-system-host-name os)))))
+
+ (test-end))))
+
+ (gexp->derivation "deploy" (test (deploy-program new-os-source))))
+
+(define* (run-rollback-test)
+ "Run a test of an OS with a faulty bootloader running DEPLOY-PROGRAM,
+which causes a rollback."
+ (define bad-os-source
+ '(begin
+ (use-modules (gnu tests))
+ (operating-system
+ (inherit %simple-os)
+ (host-name (substring (operating-system-host-name %simple-os)
+ 0 1))
+ (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)
+ (ice-9 match)
+ (srfi srfi-64))
+
+ (define marionette
+ (make-marionette (list #$vm)))
+
+ #$system-generations-definition
+
+ (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-assert "uname"
+ (match (marionette-eval '(uname) marionette)
+ (#("Linux" host-name _ ...)
+ (string=? host-name #$(operating-system-host-name os)))))
+
+ (test-end))))
+
+ (gexp->derivation "rollback" (test (deploy-program bad-os-source))))
+
+(define %test-deploy
+ (system-test
+ (name "deploy")
+ (description "Deploy to the local machine.")
+ (value (run-deploy-test))))
+
+(define %test-rollback
+ (system-test
+ (name "deploy-rollback")
+ (description "Rollback guix deploy with a faulty bootloader.")
+ (value (run-rollback-test))))
--
2.48.1
guix-patches <at> gnu.org:bug#75010; Package guix-patches.
(Sun, 01 Jun 2025 16:29:02 GMT) Full text and rfc822 format available.Message #85 received at 75010 <at> debbugs.gnu.org (full text, mbox):
From: Herman Rimm <herman <at> rimm.ee> To: 75010 <at> debbugs.gnu.org Cc: Lilah Tascheter <lilah <at> lunabee.space>, Ludovic Courtès <ludo <at> gnu.org>, Sergey Trofimov <sarg <at> sarg.org.ru> Subject: Roll back when deployment fails. Date: Sun, 1 Jun 2025 18:26:46 +0200
Hello, For now, I opened a pull request on Codeberg for issue #75010: https://codeberg.org/guix/guix/pulls/372 Cheers, Herman
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.