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 | ||
82 | (mkdir #$output) | |
83 | (chdir #$output) | |
84 | ||
85 | (test-begin "switch-to-system") | |
86 | ||
87 | (let ((generations-prior (system-generations marionette))) | |
88 | (test-assert "script successfully evaluated" | |
89 | (marionette-eval | |
90 | '(primitive-load #$script) | |
91 | marionette)) | |
92 | ||
93 | (test-equal "script created new generation" | |
94 | (length (system-generations marionette)) | |
ec12235c JK |
95 | (1+ (length generations-prior))) |
96 | ||
97 | (test-assert "script activated the new generation" | |
98 | (and (eqv? 'symlink | |
99 | (marionette-eval | |
100 | '(stat:type (lstat "/run/current-system")) | |
101 | marionette)) | |
102 | (string= #$os | |
103 | (marionette-eval | |
104 | '(readlink "/run/current-system") | |
105 | marionette)))) | |
106 | ||
107 | (test-assert "script activated user accounts" | |
108 | (marionette-eval | |
109 | '(string-contains (call-with-input-file "/etc/passwd" | |
110 | (lambda (port) | |
111 | (get-string-all port))) | |
112 | "jakob") | |
113 | marionette))) | |
d23a00b5 JK |
114 | |
115 | (test-end) | |
116 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) | |
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 | |
122 | Shepherd (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 that does nothing, for the sole purpose of ensuring | |
133 | ;; that it is properly installed and started by the script. | |
134 | (shepherd-service (provision '(dummy)) | |
135 | (start #~(const #t)) | |
136 | (stop #~(const #t)) | |
137 | (respawn? #f))) | |
138 | ||
139 | ;; Return the Shepherd service file for SERVICE, after ensuring that it | |
140 | ;; exists in the store. | |
141 | (define (ensure-service-file service) | |
142 | (let ((file (shepherd-service-file service))) | |
143 | (mlet* %store-monad ((store-object (lower-object file)) | |
144 | (_ (built-derivations (list store-object)))) | |
145 | (return file)))) | |
146 | ||
147 | (define (test enable-dummy disable-dummy) | |
148 | (with-imported-modules '((gnu build marionette)) | |
149 | #~(begin | |
150 | (use-modules (gnu build marionette) | |
151 | (srfi srfi-64)) | |
152 | ||
153 | (define marionette | |
154 | (make-marionette (list #$vm))) | |
155 | ||
156 | ;; Return the names of the running services on MARIONETTE. | |
157 | (define (running-services marionette) | |
158 | (marionette-eval | |
159 | '(begin | |
160 | (use-modules (gnu services herd)) | |
161 | (map live-service-canonical-name (current-services))) | |
162 | marionette)) | |
163 | ||
164 | (mkdir #$output) | |
165 | (chdir #$output) | |
166 | ||
167 | (test-begin "upgrade-services") | |
168 | ||
169 | (let ((services-prior (running-services marionette))) | |
170 | (test-assert "script successfully evaluated" | |
171 | (marionette-eval | |
172 | '(primitive-load #$enable-dummy) | |
173 | marionette)) | |
174 | ||
175 | (test-assert "script started new service" | |
176 | (and (not (memq 'dummy services-prior)) | |
177 | (memq 'dummy (running-services marionette)))) | |
178 | ||
179 | (test-assert "script successfully evaluated" | |
180 | (marionette-eval | |
181 | '(primitive-load #$disable-dummy) | |
182 | marionette)) | |
183 | ||
184 | (test-assert "script stopped obsolete service" | |
185 | (not (memq 'dummy (running-services marionette))))) | |
186 | ||
187 | (test-end) | |
188 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) | |
189 | ||
190 | (mlet* %store-monad ((file (ensure-service-file dummy-service))) | |
191 | (let ((enable (upgrade-services-program (list file) '(dummy) '() '())) | |
192 | (disable (upgrade-services-program '() '() '(dummy) '()))) | |
193 | (gexp->derivation "upgrade-services" (test enable disable))))) | |
194 | ||
195 | (define* (run-install-bootloader-test) | |
196 | "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs a | |
197 | bootloader's configuration file." | |
198 | (define os | |
199 | (marionette-operating-system | |
200 | (simple-operating-system) | |
201 | #:imported-modules '((gnu services herd) | |
202 | (guix combinators)))) | |
203 | ||
204 | (define vm (virtual-machine os)) | |
205 | ||
206 | (define (test script) | |
207 | (with-imported-modules '((gnu build marionette)) | |
208 | #~(begin | |
209 | (use-modules (gnu build marionette) | |
210 | (ice-9 regex) | |
211 | (srfi srfi-1) | |
212 | (srfi srfi-64)) | |
213 | ||
214 | (define marionette | |
215 | (make-marionette (list #$vm))) | |
216 | ||
217 | ;; Return the system generation paths that have GRUB menu entries. | |
218 | (define (generations-in-grub-cfg marionette) | |
219 | (let ((grub-cfg (marionette-eval | |
220 | '(begin | |
221 | (call-with-input-file "/boot/grub/grub.cfg" | |
222 | (lambda (port) | |
223 | (get-string-all port)))) | |
224 | marionette))) | |
225 | (map (lambda (parameter) | |
226 | (second (string-split (match:substring parameter) #\=))) | |
227 | (list-matches "system=[^ ]*" grub-cfg)))) | |
228 | ||
229 | (mkdir #$output) | |
230 | (chdir #$output) | |
231 | ||
232 | (test-begin "install-bootloader") | |
233 | ||
234 | (test-assert "no prior menu entry for system generation" | |
235 | (not (member #$os (generations-in-grub-cfg marionette)))) | |
236 | ||
237 | (test-assert "script successfully evaluated" | |
238 | (marionette-eval | |
239 | '(primitive-load #$script) | |
240 | marionette)) | |
241 | ||
242 | (test-assert "menu entry created for system generation" | |
243 | (member #$os (generations-in-grub-cfg marionette))) | |
244 | ||
245 | (test-end) | |
246 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) | |
247 | ||
248 | (let* ((bootloader ((compose bootloader-configuration-bootloader | |
249 | operating-system-bootloader) | |
250 | os)) | |
251 | ;; The typical use-case for 'install-bootloader-program' is to read | |
252 | ;; the boot parameters for the existing menu entries on the system, | |
253 | ;; parse them with 'boot-parameters->menu-entry', and pass the | |
254 | ;; results to 'operating-system-bootcfg'. However, to obtain boot | |
255 | ;; parameters, we would need to start the marionette, which we should | |
256 | ;; ideally avoid doing outside of the 'test' G-Expression. Thus, we | |
257 | ;; generate a bootloader configuration for the script as if there | |
258 | ;; were no existing menu entries. In the grand scheme of things, this | |
259 | ;; matters little -- these tests should not make assertions about the | |
260 | ;; behavior of 'operating-system-bootcfg'. | |
261 | (bootcfg (operating-system-bootcfg os '())) | |
262 | (bootcfg-file (bootloader-configuration-file bootloader))) | |
263 | (gexp->derivation | |
264 | "install-bootloader" | |
265 | ;; Due to the read-only nature of the virtual machines used in the system | |
266 | ;; test suite, the bootloader installer script is omitted. 'grub-install' | |
267 | ;; would attempt to write directly to the virtual disk if the | |
268 | ;; installation script were run. | |
269 | (test (install-bootloader-program #f #f bootcfg bootcfg-file #f "/"))))) | |
270 | ||
271 | (define %test-switch-to-system | |
272 | (system-test | |
273 | (name "switch-to-system") | |
274 | (description "Create a new generation of the system profile.") | |
275 | (value (run-switch-to-system-test)))) | |
276 | ||
277 | (define %test-upgrade-services | |
278 | (system-test | |
279 | (name "upgrade-services") | |
280 | (description "Upgrade the Shepherd by unloading obsolete services and | |
281 | loading new services.") | |
282 | (value (run-upgrade-services-test)))) | |
283 | ||
284 | (define %test-install-bootloader | |
285 | (system-test | |
286 | (name "install-bootloader") | |
287 | (description "Install a bootloader and its configuration file.") | |
288 | (value (run-install-bootloader-test)))) |