projects/guix·blob java-team · refs

361 lines · 13.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2019 Jakob L. Kreuze <[email protected]>
3;;; Copyright © 2024-2025 Ludovic Courtès <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20(define-module (gnu tests reconfigure)
21 #:use-module (gnu bootloader)
22 #:use-module (gnu services)
23 #:use-module (gnu services base)
24 #:use-module (gnu services shepherd)
25 #:use-module (gnu system)
26 #:use-module (gnu system accounts)
27 #:use-module (gnu system file-systems)
28 #:use-module (gnu system shadow)
29 #:use-module (gnu system vm)
30 #:use-module (gnu tests)
31 #:use-module (guix derivations)
32 #:use-module (guix gexp)
33 #:use-module (guix monads)
34 #:use-module (guix scripts system reconfigure)
35 #:use-module (guix store)
36 #:export (%test-switch-to-system
37 %test-upgrade-services
38 %test-upgrade-kexec
39 %test-install-bootloader))
40
41;;; Commentary:
42;;;
43;;; Test in-place system reconfiguration: advancing the system generation on a
44;;; running instance of the Guix System.
45;;;
46;;; Code:
47
48(define* (run-switch-to-system-test)
49 "Run a test of an OS running SWITCH-SYSTEM-PROGRAM, which creates a new
50generation of the system profile."
51 (define os
52 (marionette-operating-system
53 (operating-system
54 (inherit (simple-operating-system))
55 (users (cons (user-account
56 (name "jakob")
57 (group "users")
58 (home-directory "/home/jakob"))
59 %base-user-accounts)))
60 #:imported-modules '((gnu services herd)
61 (guix combinators))))
62
63 (define vm (virtual-machine os))
64
65 (define (test script)
66 (with-imported-modules '((gnu build marionette))
67 #~(begin
68 (use-modules (gnu build marionette)
69 (srfi srfi-64))
70
71 (define marionette
72 (make-marionette (list #$vm)))
73
74 ;; Return the names of the generation symlinks on MARIONETTE.
75 (define (system-generations marionette)
76 (marionette-eval
77 '(begin
78 (use-modules (ice-9 ftw)
79 (srfi srfi-1))
80 (let* ((profile-dir "/var/guix/profiles/")
81 (entries (map first (cddr (file-system-tree profile-dir)))))
82 (remove (lambda (entry)
83 (member entry '("per-user" "system")))
84 entries)))
85 marionette))
86
87 (test-runner-current (system-test-runner #$output))
88 (test-begin "switch-to-system")
89
90 (let ((generations-prior (system-generations marionette)))
91 (test-assert "script successfully evaluated"
92 (marionette-eval
93 '(primitive-load #$script)
94 marionette))
95
96 (test-equal "script created new generation"
97 (length (system-generations marionette))
98 (1+ (length generations-prior)))
99
100 (test-equal "script activated the new generation"
101 (string-append "/var/guix/profiles/system-"
102 (number->string (+ 1 (length generations-prior)))
103 "-link")
104 (marionette-eval '(readlink "/run/current-system")
105 marionette))
106
107 (test-assert "script activated user accounts"
108 (marionette-eval
109 '(begin
110 (use-modules (rnrs io ports))
111 (string-contains (call-with-input-file "/etc/passwd"
112 get-string-all)
113 "jakob"))
114 marionette)))
115
116 (test-end))))
117
118 (gexp->derivation "switch-to-system" (test (switch-system-program os))))
119
120(define* (run-upgrade-services-test)
121 "Run a test of an OS running UPGRADE-SERVICES-PROGRAM, which upgrades the
122Shepherd (PID 1) by unloading obsolete services and loading new services."
123 (define os
124 (marionette-operating-system
125 (simple-operating-system)
126 #:imported-modules '((gnu services herd)
127 (guix combinators))))
128
129 (define vm (virtual-machine os))
130
131 (define dummy-service
132 ;; Shepherd service for the purpose of capturing the value of
133 ;; 'default-environment-variables' at the time it was loaded and ensuring
134 ;; that it is properly installed and started by the script.
135 (shepherd-service (provision '(dummy))
136 (start #~(const (default-environment-variables)))
137 (stop #~(const #t))
138 (respawn? #f)))
139
140 (define (test enable-dummy disable-dummy)
141 (with-imported-modules '((gnu build marionette))
142 #~(begin
143 (use-modules (gnu build marionette)
144 (srfi srfi-64))
145
146 (define marionette
147 (make-marionette (list #$vm)))
148
149 ;; Return the names of the running services on MARIONETTE.
150 (define (running-services marionette)
151 (marionette-eval
152 '(begin
153 (use-modules (gnu services herd))
154 (map live-service-canonical-name (current-services)))
155 marionette))
156
157 (test-runner-current (system-test-runner #$output))
158 (test-begin "upgrade-services")
159
160 (let ((services-prior (running-services marionette)))
161 (test-assert "script successfully evaluated"
162 (marionette-eval
163 '(primitive-load #$enable-dummy)
164 marionette))
165
166 (test-assert "script started new service"
167 (and (not (memq 'dummy services-prior))
168 (memq 'dummy (running-services marionette))))
169
170 (test-equal "script set default environment"
171 '("PATH=/run/current-system/profile/bin")
172 (marionette-eval
173 '(begin
174 (use-modules (gnu services herd))
175 (wait-for-service 'dummy))
176 marionette))
177
178 (test-assert "script successfully evaluated"
179 (marionette-eval
180 '(primitive-load #$disable-dummy)
181 marionette))
182
183 (test-assert "script stopped obsolete service"
184 (not (memq 'dummy (running-services marionette)))))
185
186 (test-end))))
187
188 (gexp->derivation
189 "upgrade-services"
190 (let* ((file (shepherd-service-file dummy-service))
191 (enable (upgrade-services-program (list file) '(dummy) '() '()))
192 (disable (upgrade-services-program '() '() '(dummy) '())))
193 (test enable disable))))
194
195(define (run-kexec-test)
196 "Run a test aiming to reboot via Linux kexec into a new system."
197 (define os
198 (marionette-operating-system
199 (operating-system
200 (inherit %simple-os)
201 (services (modify-services %base-services
202 (shepherd-system-log-service-type
203 config
204 =>
205 (system-log-configuration
206 (inherit config)
207 (message-destination #~(const '("/dev/console"))))))))
208 #:imported-modules '((gnu services herd)
209 (guix combinators))))
210
211 (define new-os
212 (marionette-operating-system
213 (virtualized-operating-system ;run as with "guix system vm"
214 (operating-system
215 (inherit %simple-os)
216 (host-name "the-new-os")
217 (kernel-arguments '("console=ttyS0"))) ;be verbose
218 #:volatile? #t) ;mount root read-only
219 #:imported-modules '((gnu services herd)
220 (guix combinators))))
221
222 (define vm (virtual-machine os))
223
224 (define test
225 (with-imported-modules '((gnu build marionette))
226 #~(begin
227 (use-modules (gnu build marionette)
228 (srfi srfi-64))
229
230 (define marionette
231 (make-marionette (list #$vm)))
232
233 (test-runner-current (system-test-runner #$output))
234 (test-begin "kexec")
235
236 (test-equal "host name"
237 #$(operating-system-host-name os)
238 (marionette-eval '(gethostname) marionette))
239
240 (test-assert "kexec-loading-program"
241 (marionette-eval
242 '(primitive-load #$(kexec-loading-program new-os))
243 marionette))
244
245 (test-assert "reboot/kexec"
246 (marionette-eval
247 '(begin
248 (use-modules (gnu services herd))
249 (with-shepherd-action 'root ('kexec) result
250 (pk 'reboot-kexec result)))
251 marionette))
252
253 (test-equal "host name of new OS"
254 #$(operating-system-host-name new-os)
255 (marionette-eval '(gethostname) marionette))
256
257 (test-end))))
258
259 (gexp->derivation "kexec-test" test))
260
261(define* (run-install-bootloader-test)
262 "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs a
263bootloader's configuration file."
264 (define os
265 (marionette-operating-system
266 (simple-operating-system)
267 #:imported-modules '((gnu services herd)
268 (guix combinators))))
269
270 (define vm (virtual-machine
271 (operating-system os)
272 (volatile? #f)))
273
274 (define (test script)
275 (with-imported-modules '((gnu build marionette))
276 #~(begin
277 (use-modules (gnu build marionette)
278 (ice-9 regex)
279 (srfi srfi-1)
280 (srfi srfi-64))
281
282 (define marionette
283 (make-marionette (list #$vm)))
284
285 ;; Return the system generation paths that have GRUB menu entries.
286 (define (generations-in-grub-cfg marionette)
287 (let ((grub-cfg (marionette-eval
288 '(begin
289 (use-modules (rnrs io ports))
290 (call-with-input-file "/boot/grub/grub.cfg"
291 get-string-all))
292 marionette)))
293 (map (lambda (parameter)
294 (second (string-split (match:substring parameter) #\=)))
295 (list-matches "system=[^ ]*" grub-cfg))))
296
297 (test-runner-current (system-test-runner #$output))
298 (test-begin "install-bootloader")
299
300 (test-assert "no prior menu entry for system generation"
301 (not (member #$os (generations-in-grub-cfg marionette))))
302
303 (test-assert "script successfully evaluated"
304 (marionette-eval
305 '(primitive-load #$script)
306 marionette))
307
308 (test-assert "menu entry created for system generation"
309 (member #$os (generations-in-grub-cfg marionette)))
310
311 (test-end))))
312
313 (let* ((bootloader ((compose bootloader-configuration-bootloader
314 operating-system-bootloader)
315 os))
316 ;; The typical use-case for 'install-bootloader-program' is to read
317 ;; the boot parameters for the existing menu entries on the system,
318 ;; parse them with 'boot-parameters->menu-entry', and pass the
319 ;; results to 'operating-system-bootcfg'. However, to obtain boot
320 ;; parameters, we would need to start the marionette, which we should
321 ;; ideally avoid doing outside of the 'test' G-Expression. Thus, we
322 ;; generate a bootloader configuration for the script as if there
323 ;; were no existing menu entries. In the grand scheme of things, this
324 ;; matters little -- these tests should not make assertions about the
325 ;; behavior of 'operating-system-bootcfg'.
326 (bootcfg (operating-system-bootcfg os '()))
327 (bootcfg-file (bootloader-configuration-file bootloader)))
328 (gexp->derivation
329 "install-bootloader"
330 ;; Due to the read-only nature of the virtual machines used in the system
331 ;; test suite, the bootloader installer script is omitted. 'grub-install'
332 ;; would attempt to write directly to the virtual disk if the
333 ;; installation script were run.
334 (test
335 (install-bootloader-program #f #f #f bootcfg bootcfg-file '(#f) "/")))))
336
337
338(define %test-switch-to-system
339 (system-test
340 (name "switch-to-system")
341 (description "Create a new generation of the system profile.")
342 (value (run-switch-to-system-test))))
343
344(define %test-upgrade-services
345 (system-test
346 (name "upgrade-services")
347 (description "Upgrade the Shepherd by unloading obsolete services and
348loading new services.")
349 (value (run-upgrade-services-test))))
350
351(define %test-upgrade-kexec
352 (system-test
353 (name "upgrade-kexec")
354 (description "Load a system and reboot into it via Linux kexec.")
355 (value (run-kexec-test))))
356
357(define %test-install-bootloader
358 (system-test
359 (name "install-bootloader")
360 (description "Install a bootloader and its configuration file.")
361 (value (run-install-bootloader-test))))