Commit | Line | Data |
---|---|---|
d23a00b5 | 1 | ;;; GNU Guix --- Functional package management for GNU |
e8134442 | 2 | ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org> |
d23a00b5 JK |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (gnu tests reconfigure) | |
20 | #:use-module (gnu bootloader) | |
21 | #:use-module (gnu services shepherd) | |
d23a00b5 | 22 | #:use-module (gnu system) |
ec12235c JK |
23 | #:use-module (gnu system accounts) |
24 | #:use-module (gnu system shadow) | |
25 | #:use-module (gnu system vm) | |
d23a00b5 JK |
26 | #:use-module (gnu tests) |
27 | #:use-module (guix derivations) | |
28 | #:use-module (guix gexp) | |
29 | #:use-module (guix monads) | |
30 | #:use-module (guix scripts system reconfigure) | |
31 | #:use-module (guix store) | |
32 | #:export (%test-switch-to-system | |
33 | %test-upgrade-services | |
34 | %test-install-bootloader)) | |
35 | ||
36 | ;;; Commentary: | |
37 | ;;; | |
38 | ;;; Test in-place system reconfiguration: advancing the system generation on a | |
39 | ;;; running instance of the Guix System. | |
40 | ;;; | |
41 | ;;; Code: | |
42 | ||
43 | (define* (run-switch-to-system-test) | |
44 | "Run a test of an OS running SWITCH-SYSTEM-PROGRAM, which creates a new | |
45 | generation of the system profile." | |
46 | (define os | |
47 | (marionette-operating-system | |
ec12235c JK |
48 | (operating-system |
49 | (inherit (simple-operating-system)) | |
50 | (users (cons (user-account | |
51 | (name "jakob") | |
52 | (group "users") | |
53 | (home-directory "/home/jakob")) | |
54 | %base-user-accounts))) | |
d23a00b5 JK |
55 | #:imported-modules '((gnu services herd) |
56 | (guix combinators)))) | |
57 | ||
58 | (define vm (virtual-machine os)) | |
59 | ||
60 | (define (test script) | |
61 | (with-imported-modules '((gnu build marionette)) | |
62 | #~(begin | |
63 | (use-modules (gnu build marionette) | |
64 | (srfi srfi-64)) | |
65 | ||
66 | (define marionette | |
67 | (make-marionette (list #$vm))) | |
68 | ||
69 | ;; Return the names of the generation symlinks on MARIONETTE. | |
70 | (define (system-generations marionette) | |
71 | (marionette-eval | |
72 | '(begin | |
73 | (use-modules (ice-9 ftw) | |
74 | (srfi srfi-1)) | |
75 | (let* ((profile-dir "/var/guix/profiles/") | |
76 | (entries (map first (cddr (file-system-tree profile-dir))))) | |
77 | (remove (lambda (entry) | |
78 | (member entry '("per-user" "system"))) | |
79 | entries))) | |
80 | marionette)) | |
81 | ||
89b05442 | 82 | (test-runner-current (system-test-runner #$output)) |
d23a00b5 JK |
83 | (test-begin "switch-to-system") |
84 | ||
85 | (let ((generations-prior (system-generations marionette))) | |
86 | (test-assert "script successfully evaluated" | |
87 | (marionette-eval | |
88 | '(primitive-load #$script) | |
89 | marionette)) | |
90 | ||
91 | (test-equal "script created new generation" | |
92 | (length (system-generations marionette)) | |
ec12235c JK |
93 | (1+ (length generations-prior))) |
94 | ||
95 | (test-assert "script activated the new generation" | |
96 | (and (eqv? 'symlink | |
97 | (marionette-eval | |
98 | '(stat:type (lstat "/run/current-system")) | |
99 | marionette)) | |
100 | (string= #$os | |
101 | (marionette-eval | |
102 | '(readlink "/run/current-system") | |
103 | marionette)))) | |
104 | ||
105 | (test-assert "script activated user accounts" | |
106 | (marionette-eval | |
107 | '(string-contains (call-with-input-file "/etc/passwd" | |
108 | (lambda (port) | |
109 | (get-string-all port))) | |
110 | "jakob") | |
111 | marionette))) | |
d23a00b5 | 112 | |
1fb75128 | 113 | (test-end)))) |
d23a00b5 JK |
114 | |
115 | (gexp->derivation "switch-to-system" (test (switch-system-program os)))) | |
116 | ||
117 | (define* (run-upgrade-services-test) | |
118 | "Run a test of an OS running UPGRADE-SERVICES-PROGRAM, which upgrades the | |
119 | Shepherd (PID 1) by unloading obsolete services and loading new services." | |
120 | (define os | |
121 | (marionette-operating-system | |
122 | (simple-operating-system) | |
123 | #:imported-modules '((gnu services herd) | |
124 | (guix combinators)))) | |
125 | ||
126 | (define vm (virtual-machine os)) | |
127 | ||
128 | (define dummy-service | |
129 | ;; Shepherd service that does nothing, for the sole purpose of ensuring | |
130 | ;; that it is properly installed and started by the script. | |
131 | (shepherd-service (provision '(dummy)) | |
132 | (start #~(const #t)) | |
133 | (stop #~(const #t)) | |
134 | (respawn? #f))) | |
135 | ||
d23a00b5 JK |
136 | (define (test enable-dummy disable-dummy) |
137 | (with-imported-modules '((gnu build marionette)) | |
138 | #~(begin | |
139 | (use-modules (gnu build marionette) | |
140 | (srfi srfi-64)) | |
141 | ||
142 | (define marionette | |
143 | (make-marionette (list #$vm))) | |
144 | ||
145 | ;; Return the names of the running services on MARIONETTE. | |
146 | (define (running-services marionette) | |
147 | (marionette-eval | |
148 | '(begin | |
149 | (use-modules (gnu services herd)) | |
150 | (map live-service-canonical-name (current-services))) | |
151 | marionette)) | |
152 | ||
89b05442 | 153 | (test-runner-current (system-test-runner #$output)) |
d23a00b5 JK |
154 | (test-begin "upgrade-services") |
155 | ||
156 | (let ((services-prior (running-services marionette))) | |
157 | (test-assert "script successfully evaluated" | |
158 | (marionette-eval | |
159 | '(primitive-load #$enable-dummy) | |
160 | marionette)) | |
161 | ||
162 | (test-assert "script started new service" | |
163 | (and (not (memq 'dummy services-prior)) | |
164 | (memq 'dummy (running-services marionette)))) | |
165 | ||
166 | (test-assert "script successfully evaluated" | |
167 | (marionette-eval | |
168 | '(primitive-load #$disable-dummy) | |
169 | marionette)) | |
170 | ||
171 | (test-assert "script stopped obsolete service" | |
172 | (not (memq 'dummy (running-services marionette))))) | |
173 | ||
1fb75128 | 174 | (test-end)))) |
d23a00b5 | 175 | |
53aa66c3 CB |
176 | (gexp->derivation |
177 | "upgrade-services" | |
178 | (let* ((file (shepherd-service-file dummy-service)) | |
179 | (enable (upgrade-services-program (list file) '(dummy) '() '())) | |
d23a00b5 | 180 | (disable (upgrade-services-program '() '() '(dummy) '()))) |
53aa66c3 | 181 | (test enable disable)))) |
d23a00b5 JK |
182 | |
183 | (define* (run-install-bootloader-test) | |
184 | "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs a | |
185 | bootloader's configuration file." | |
186 | (define os | |
187 | (marionette-operating-system | |
188 | (simple-operating-system) | |
189 | #:imported-modules '((gnu services herd) | |
190 | (guix combinators)))) | |
191 | ||
7682145b MO |
192 | (define vm (virtual-machine |
193 | (operating-system os) | |
194 | (volatile? #f))) | |
d23a00b5 JK |
195 | |
196 | (define (test script) | |
197 | (with-imported-modules '((gnu build marionette)) | |
198 | #~(begin | |
199 | (use-modules (gnu build marionette) | |
200 | (ice-9 regex) | |
201 | (srfi srfi-1) | |
202 | (srfi srfi-64)) | |
203 | ||
204 | (define marionette | |
205 | (make-marionette (list #$vm))) | |
206 | ||
207 | ;; Return the system generation paths that have GRUB menu entries. | |
208 | (define (generations-in-grub-cfg marionette) | |
209 | (let ((grub-cfg (marionette-eval | |
210 | '(begin | |
211 | (call-with-input-file "/boot/grub/grub.cfg" | |
212 | (lambda (port) | |
213 | (get-string-all port)))) | |
214 | marionette))) | |
215 | (map (lambda (parameter) | |
216 | (second (string-split (match:substring parameter) #\=))) | |
217 | (list-matches "system=[^ ]*" grub-cfg)))) | |
218 | ||
89b05442 | 219 | (test-runner-current (system-test-runner #$output)) |
d23a00b5 JK |
220 | (test-begin "install-bootloader") |
221 | ||
222 | (test-assert "no prior menu entry for system generation" | |
223 | (not (member #$os (generations-in-grub-cfg marionette)))) | |
224 | ||
225 | (test-assert "script successfully evaluated" | |
226 | (marionette-eval | |
227 | '(primitive-load #$script) | |
228 | marionette)) | |
229 | ||
230 | (test-assert "menu entry created for system generation" | |
231 | (member #$os (generations-in-grub-cfg marionette))) | |
232 | ||
1fb75128 | 233 | (test-end)))) |
d23a00b5 JK |
234 | |
235 | (let* ((bootloader ((compose bootloader-configuration-bootloader | |
236 | operating-system-bootloader) | |
237 | os)) | |
238 | ;; The typical use-case for 'install-bootloader-program' is to read | |
239 | ;; the boot parameters for the existing menu entries on the system, | |
240 | ;; parse them with 'boot-parameters->menu-entry', and pass the | |
241 | ;; results to 'operating-system-bootcfg'. However, to obtain boot | |
242 | ;; parameters, we would need to start the marionette, which we should | |
243 | ;; ideally avoid doing outside of the 'test' G-Expression. Thus, we | |
244 | ;; generate a bootloader configuration for the script as if there | |
245 | ;; were no existing menu entries. In the grand scheme of things, this | |
246 | ;; matters little -- these tests should not make assertions about the | |
247 | ;; behavior of 'operating-system-bootcfg'. | |
248 | (bootcfg (operating-system-bootcfg os '())) | |
249 | (bootcfg-file (bootloader-configuration-file bootloader))) | |
250 | (gexp->derivation | |
251 | "install-bootloader" | |
252 | ;; Due to the read-only nature of the virtual machines used in the system | |
253 | ;; test suite, the bootloader installer script is omitted. 'grub-install' | |
254 | ;; would attempt to write directly to the virtual disk if the | |
255 | ;; installation script were run. | |
a38d861e | 256 | (test |
2ca982ff | 257 | (install-bootloader-program #f #f #f bootcfg bootcfg-file '(#f) "/"))))) |
a38d861e | 258 | |
d23a00b5 JK |
259 | |
260 | (define %test-switch-to-system | |
261 | (system-test | |
262 | (name "switch-to-system") | |
263 | (description "Create a new generation of the system profile.") | |
264 | (value (run-switch-to-system-test)))) | |
265 | ||
266 | (define %test-upgrade-services | |
267 | (system-test | |
268 | (name "upgrade-services") | |
269 | (description "Upgrade the Shepherd by unloading obsolete services and | |
270 | loading new services.") | |
271 | (value (run-upgrade-services-test)))) | |
272 | ||
273 | (define %test-install-bootloader | |
274 | (system-test | |
275 | (name "install-bootloader") | |
276 | (description "Install a bootloader and its configuration file.") | |
277 | (value (run-install-bootloader-test)))) |