Commit | Line | Data |
---|---|---|
ccb1a8c4 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> | |
7a1a10db | 3 | ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> |
ccb1a8c4 LC |
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 installer tests) | |
21 | #:use-module (srfi srfi-1) | |
22 | #:use-module (srfi srfi-34) | |
23 | #:use-module (srfi srfi-35) | |
24 | #:use-module (ice-9 match) | |
25 | #:use-module (ice-9 regex) | |
26 | #:use-module (ice-9 pretty-print) | |
27 | #:export (&pattern-not-matched | |
28 | pattern-not-matched? | |
29 | ||
30 | %installer-socket-file | |
31 | open-installer-socket | |
32 | ||
33 | converse | |
34 | conversation-log-port | |
35 | ||
36 | choose-locale+keyboard | |
37 | enter-host-name+passwords | |
38 | choose-services | |
39 | choose-partitioning | |
95b3fc12 MO |
40 | start-installation |
41 | complete-installation | |
ccb1a8c4 LC |
42 | |
43 | edit-configuration-file)) | |
44 | ||
45 | ;;; Commentary: | |
46 | ;;; | |
47 | ;;; This module provides tools to test the guided "graphical" installer in a | |
48 | ;;; non-interactive fashion. The core of it is 'converse': it allows you to | |
49 | ;;; state Expect-style dialogues, which happen over the Unix-domain socket the | |
50 | ;;; installer listens to. Higher-level procedures such as | |
51 | ;;; 'choose-locale+keyboard' are provided to perform specific parts of the | |
52 | ;;; dialogue. | |
53 | ;;; | |
54 | ;;; Code: | |
55 | ||
56 | (define %installer-socket-file | |
57 | ;; Socket the installer listens to. | |
58 | "/var/guix/installer-socket") | |
59 | ||
60 | (define* (open-installer-socket #:optional (file %installer-socket-file)) | |
61 | "Return a socket connected to the installer." | |
62 | (let ((sock (socket AF_UNIX SOCK_STREAM 0))) | |
63 | (connect sock AF_UNIX file) | |
64 | sock)) | |
65 | ||
66 | (define-condition-type &pattern-not-matched &error | |
67 | pattern-not-matched? | |
68 | (pattern pattern-not-matched-pattern) | |
69 | (sexp pattern-not-matched-sexp)) | |
70 | ||
71 | (define (pattern-error pattern sexp) | |
72 | (raise (condition | |
73 | (&pattern-not-matched | |
74 | (pattern pattern) (sexp sexp))))) | |
75 | ||
76 | (define conversation-log-port | |
77 | ;; Port where debugging info is logged | |
78 | (make-parameter (current-error-port))) | |
79 | ||
80 | (define (converse-debug pattern) | |
81 | (format (conversation-log-port) | |
82 | "conversation expecting pattern ~s~%" | |
83 | pattern)) | |
84 | ||
85 | (define-syntax converse | |
86 | (lambda (s) | |
87 | "Convert over PORT: read sexps from there, match them against each | |
88 | PATTERN, and send the corresponding REPLY. Raise to '&pattern-not-matched' | |
89 | when one of the PATTERNs is not matched." | |
90 | ||
91 | ;; XXX: Strings that appear in PATTERNs must be in the language the | |
92 | ;; installer is running in. In the future, we should add support to allow | |
93 | ;; writing English strings in PATTERNs and have the pattern matcher | |
94 | ;; automatically translate them. | |
95 | ||
96 | ;; Here we emulate 'pmatch' syntax on top of 'match'. This is ridiculous | |
97 | ;; but that's because 'pmatch' compares objects with 'eq?', making it | |
98 | ;; pretty useless, and it doesn't support ellipses and such. | |
99 | ||
100 | (define (quote-pattern s) | |
101 | ;; Rewrite the pattern S from pmatch style (a ,b) to match style like | |
102 | ;; ('a b). | |
103 | (with-ellipsis ::: | |
104 | (syntax-case s (unquote _ ...) | |
105 | ((unquote id) #'id) | |
106 | (_ #'_) | |
107 | (... #'...) | |
108 | (id | |
109 | (identifier? #'id) | |
110 | #''id) | |
111 | ((lst :::) (map quote-pattern #'(lst :::))) | |
112 | (pattern #'pattern)))) | |
113 | ||
114 | (define (match-pattern s) | |
115 | ;; Match one pattern without a guard. | |
116 | (syntax-case s () | |
117 | ((port (pattern reply) continuation) | |
118 | (with-syntax ((pattern (quote-pattern #'pattern))) | |
119 | #'(let ((pat 'pattern)) | |
120 | (converse-debug pat) | |
121 | (match (read port) | |
122 | (pattern | |
123 | (let ((data (call-with-values (lambda () reply) | |
124 | list))) | |
125 | (for-each (lambda (obj) | |
126 | (write obj port) | |
127 | (newline port)) | |
128 | data) | |
129 | (force-output port) | |
130 | (continuation port))) | |
131 | (sexp | |
132 | (pattern-error pat sexp)))))))) | |
133 | ||
134 | (syntax-case s () | |
135 | ((_ port (pattern reply) rest ...) | |
136 | (match-pattern #'(port (pattern reply) | |
137 | (lambda (port) | |
138 | (converse port rest ...))))) | |
139 | ((_ port (pattern guard reply) rest ...) | |
140 | #`(let ((skip? (not guard)) | |
141 | (next (lambda (p) | |
142 | (converse p rest ...)))) | |
143 | (if skip? | |
144 | (next port) | |
145 | #,(match-pattern #'(port (pattern reply) next))))) | |
146 | ((_ port) | |
147 | #t)))) | |
148 | ||
149 | (define* (choose-locale+keyboard port | |
150 | #:key | |
151 | (language "English") | |
152 | (location "Hong Kong") | |
153 | (timezone '("Europe" "Zagreb")) | |
154 | (keyboard | |
155 | '("English (US)" | |
156 | "English (intl., with AltGr dead keys)"))) | |
157 | "Converse over PORT with the guided installer to choose the specified | |
158 | LANGUAGE, LOCATION, TIMEZONE, and KEYBOARD." | |
159 | (converse port | |
160 | ((list-selection (title "Locale language") | |
161 | (multiple-choices? #f) | |
162 | (items _)) | |
163 | language) | |
164 | ((list-selection (title "Locale location") | |
165 | (multiple-choices? #f) | |
166 | (items _)) | |
167 | location) | |
168 | ((menu (title "GNU Guix install") | |
169 | (text _) | |
170 | (items (,guided _ ...))) ;"Guided graphical installation" | |
171 | guided) | |
172 | ((list-selection (title "Timezone") | |
173 | (multiple-choices? #f) | |
174 | (items _)) | |
175 | (first timezone)) | |
176 | ((list-selection (title "Timezone") | |
177 | (multiple-choices? #f) | |
178 | (items _)) | |
179 | (second timezone)) | |
180 | ((list-selection (title "Layout") | |
181 | (multiple-choices? #f) | |
182 | (items _)) | |
183 | (first keyboard)) | |
184 | ((list-selection (title "Variant") | |
185 | (multiple-choices? #f) | |
186 | (items _)) | |
187 | (second keyboard)))) | |
188 | ||
189 | (define* (enter-host-name+passwords port | |
190 | #:key | |
191 | (host-name "guix") | |
192 | (root-password "foo") | |
193 | (users '(("alice" "pass1") | |
194 | ("bob" "pass2") | |
195 | ("charlie" "pass3")))) | |
196 | "Converse over PORT with the guided installer to choose HOST-NAME, | |
197 | ROOT-PASSWORD, and USERS." | |
198 | (converse port | |
199 | ((input (title "Hostname") (text _) (default _)) | |
200 | host-name) | |
201 | ((input (title "System administrator password") (text _) (default _)) | |
202 | root-password) | |
203 | ((input (title "Password confirmation required") (text _) (default _)) | |
204 | root-password) | |
205 | ((add-users) | |
206 | (match users | |
207 | (((names passwords) ...) | |
208 | (map (lambda (name password) | |
209 | `(user (name ,name) (real-name ,(string-titlecase name)) | |
210 | (home-directory ,(string-append "/home/" name)) | |
211 | (password ,password))) | |
212 | names passwords)))))) | |
213 | ||
214 | (define* (choose-services port | |
215 | #:key | |
7a1a10db | 216 | (choose-desktop-environment? (const #f)) |
ccb1a8c4 LC |
217 | (choose-network-service? |
218 | (lambda (service) | |
219 | (or (string-contains service "SSH") | |
220 | (string-contains service "NSS")))) | |
221 | (choose-network-management-tool? | |
222 | (lambda (service) | |
0dbd2c3b | 223 | (string-contains service "DHCP"))) |
2842a42b LF |
224 | (choose-misc-service? |
225 | (lambda (service) | |
226 | (string-contains service "NTP"))) | |
0dbd2c3b | 227 | (choose-other-service? (const #f))) |
2842a42b | 228 | |
0dbd2c3b | 229 | "Converse over PORT to choose services." |
7a1a10db MO |
230 | (define desktop-environments '()) |
231 | ||
ccb1a8c4 LC |
232 | (converse port |
233 | ((checkbox-list (title "Desktop environment") (text _) | |
7a1a10db MO |
234 | (items ,services)) |
235 | (let ((desktops (filter choose-desktop-environment? services))) | |
236 | (set! desktop-environments desktops) | |
237 | desktops)) | |
ccb1a8c4 LC |
238 | ((checkbox-list (title "Network service") (text _) |
239 | (items ,services)) | |
240 | (filter choose-network-service? services)) | |
241 | ||
242 | ;; The "Network management" dialog shows up only when no desktop | |
243 | ;; environments have been selected, hence the guard. | |
244 | ((list-selection (title "Network management") | |
245 | (multiple-choices? #f) | |
246 | (items ,services)) | |
247 | (null? desktop-environments) | |
0dbd2c3b TGR |
248 | (find choose-network-management-tool? services)) |
249 | ||
2842a42b LF |
250 | ((checkbox-list (title "Console services") (text _) |
251 | (items ,services)) | |
252 | (null? desktop-environments) | |
253 | (filter choose-misc-service? services)) | |
254 | ||
029f8d7c | 255 | ((checkbox-list (title "Printing and document services") (text _) |
0dbd2c3b TGR |
256 | (items ,services)) |
257 | (filter choose-other-service? services)))) | |
ccb1a8c4 LC |
258 | |
259 | (define (edit-configuration-file file) | |
260 | "Edit FILE, an operating system configuration file generated by the | |
261 | installer, by adding a marionette service such that the installed OS is | |
262 | instrumented for further testing." | |
263 | (define (read-expressions port) | |
264 | (let loop ((result '())) | |
265 | (match (read port) | |
266 | ((? eof-object?) | |
267 | (reverse result)) | |
268 | (exp | |
269 | (loop (cons exp result)))))) | |
270 | ||
271 | (define (edit exp) | |
272 | (match exp | |
273 | (('operating-system _ ...) | |
274 | `(marionette-operating-system ,exp | |
275 | #:imported-modules | |
276 | '((gnu services herd) | |
277 | (guix build utils) | |
278 | (guix combinators)))) | |
279 | (_ | |
280 | exp))) | |
281 | ||
282 | (let ((content (call-with-input-file file read-expressions))) | |
fe4663ae | 283 | ;; XXX: Remove the file before re-writing it, to be sure there are no |
f38e91a8 | 284 | ;; leftovers. We shouldn't have to do that as CALL-WITH-OUTPUT-FILE uses |
fe4663ae MO |
285 | ;; the O_TRUNC flag by default. |
286 | (delete-file file) | |
ccb1a8c4 LC |
287 | (call-with-output-file file |
288 | (lambda (port) | |
289 | (format port "\ | |
290 | ;; Operating system configuration edited for automated testing.~%~%") | |
291 | ||
292 | (pretty-print '(use-modules (gnu tests)) port) | |
293 | (for-each (lambda (exp) | |
294 | (pretty-print (edit exp) port) | |
295 | (newline port)) | |
296 | content))) | |
297 | ||
298 | #t)) | |
299 | ||
300 | (define* (choose-partitioning port | |
301 | #:key | |
302 | (encrypted? #t) | |
95b3fc12 | 303 | (uefi-support? #f) |
ccb1a8c4 LC |
304 | (passphrase "thepassphrase") |
305 | (edit-configuration-file | |
306 | edit-configuration-file)) | |
307 | "Converse over PORT to choose the partitioning method. When ENCRYPTED? is | |
308 | true, choose full-disk encryption with PASSPHRASE as the LUKS passphrase. | |
95b3fc12 MO |
309 | |
310 | When UEFI-SUPPORT? is true, assume that we are running the installation tests | |
311 | on an UEFI capable machine. | |
312 | ||
1c6d9853 LC |
313 | This conversation stops when the user partitions have been formatted, right |
314 | before the installer generates the configuration file and shows it in a dialog | |
95b3fc12 | 315 | box. " |
ccb1a8c4 LC |
316 | (converse port |
317 | ((list-selection (title "Partitioning method") | |
318 | (multiple-choices? #f) | |
319 | (items (,not-encrypted ,encrypted _ ...))) | |
320 | (if encrypted? | |
321 | encrypted | |
322 | not-encrypted)) | |
323 | ((list-selection (title "Disk") (multiple-choices? #f) | |
475d4814 LC |
324 | (items (,disks ...))) |
325 | ;; When running the installation from an ISO image, the CD/DVD drive | |
326 | ;; shows up in the list. Avoid it. | |
327 | (find (lambda (disk) | |
328 | (not (or (string-contains disk "DVD") | |
329 | (string-contains disk "CD-ROM")))) | |
330 | disks)) | |
ccb1a8c4 LC |
331 | |
332 | ;; The "Partition table" dialog pops up only if there's not already a | |
95b3fc12 | 333 | ;; partition table and if the system does not support UEFI. |
ccb1a8c4 LC |
334 | ((list-selection (title "Partition table") |
335 | (multiple-choices? #f) | |
336 | (items _)) | |
95b3fc12 MO |
337 | ;; When UEFI is supported, the partition is forced to GPT by the |
338 | ;; installer. | |
339 | (not uefi-support?) | |
ccb1a8c4 | 340 | "gpt") |
95b3fc12 | 341 | |
ccb1a8c4 LC |
342 | ((list-selection (title "Partition scheme") |
343 | (multiple-choices? #f) | |
344 | (items (,one-partition _ ...))) | |
345 | one-partition) | |
346 | ((list-selection (title "Guided partitioning") | |
347 | (multiple-choices? #f) | |
348 | (items (,disk _ ...))) | |
349 | disk) | |
350 | ((input (title "Password required") | |
351 | (text _) (default #f)) | |
352 | encrypted? ;only when ENCRYPTED? | |
353 | passphrase) | |
354 | ((input (title "Password confirmation required") | |
355 | (text _) (default #f)) | |
356 | encrypted? | |
357 | passphrase) | |
358 | ((confirmation (title "Format disk?") (text _)) | |
359 | #t) | |
360 | ((info (title "Preparing partitions") _ ...) | |
361 | (values)) ;nothing to return | |
1c6d9853 LC |
362 | ((starting-final-step) |
363 | ;; Do not return anything. The reply will be sent by | |
364 | ;; 'conclude-installation' and in the meantime the installer just waits | |
365 | ;; for us, giving us a chance to do things such as changing partition | |
366 | ;; UUIDs before it generates the configuration file. | |
367 | (values)))) | |
ccb1a8c4 | 368 | |
95b3fc12 MO |
369 | (define (start-installation port) |
370 | "Start the installation by checking over PORT that we get the generated | |
1c6d9853 | 371 | configuration file, accepting it and starting the installation, and then |
95b3fc12 | 372 | receiving the pause message once the 'guix system init' process has |
1c6d9853 LC |
373 | completed." |
374 | ;; Assume the previous message received was 'starting-final-step'; here we | |
375 | ;; send the reply to that message, which lets the installer continue. | |
376 | (write #t port) | |
377 | (newline port) | |
378 | (force-output port) | |
379 | ||
ccb1a8c4 | 380 | (converse port |
1c6d9853 LC |
381 | ((file-dialog (title "Configuration file") |
382 | (text _) | |
383 | (file ,configuration-file)) | |
384 | (edit-configuration-file configuration-file)) | |
ccb1a8c4 | 385 | ((pause) ;"Press Enter to continue." |
95b3fc12 MO |
386 | (values)))) |
387 | ||
388 | (define (complete-installation port) | |
389 | "Complete the installation by replying to the installer pause message and | |
390 | waiting for the installation-complete message." | |
391 | ;; Assume the previous message received was 'pause'; here we send the reply | |
392 | ;; to that message, which lets the installer continue. | |
393 | (write #t port) | |
394 | (newline port) | |
395 | (force-output port) | |
396 | ||
397 | (converse port | |
398 | ((installation-complete) | |
ccb1a8c4 LC |
399 | (values)))) |
400 | ||
401 | ;;; Local Variables: | |
402 | ;;; eval: (put 'converse 'scheme-indent-function 1) | |
403 | ;;; eval: (put 'with-ellipsis 'scheme-indent-function 1) | |
404 | ;;; End: |