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 | |
40 | conclude-installation | |
41 | ||
42 | edit-configuration-file)) | |
43 | ||
44 | ;;; Commentary: | |
45 | ;;; | |
46 | ;;; This module provides tools to test the guided "graphical" installer in a | |
47 | ;;; non-interactive fashion. The core of it is 'converse': it allows you to | |
48 | ;;; state Expect-style dialogues, which happen over the Unix-domain socket the | |
49 | ;;; installer listens to. Higher-level procedures such as | |
50 | ;;; 'choose-locale+keyboard' are provided to perform specific parts of the | |
51 | ;;; dialogue. | |
52 | ;;; | |
53 | ;;; Code: | |
54 | ||
55 | (define %installer-socket-file | |
56 | ;; Socket the installer listens to. | |
57 | "/var/guix/installer-socket") | |
58 | ||
59 | (define* (open-installer-socket #:optional (file %installer-socket-file)) | |
60 | "Return a socket connected to the installer." | |
61 | (let ((sock (socket AF_UNIX SOCK_STREAM 0))) | |
62 | (connect sock AF_UNIX file) | |
63 | sock)) | |
64 | ||
65 | (define-condition-type &pattern-not-matched &error | |
66 | pattern-not-matched? | |
67 | (pattern pattern-not-matched-pattern) | |
68 | (sexp pattern-not-matched-sexp)) | |
69 | ||
70 | (define (pattern-error pattern sexp) | |
71 | (raise (condition | |
72 | (&pattern-not-matched | |
73 | (pattern pattern) (sexp sexp))))) | |
74 | ||
75 | (define conversation-log-port | |
76 | ;; Port where debugging info is logged | |
77 | (make-parameter (current-error-port))) | |
78 | ||
79 | (define (converse-debug pattern) | |
80 | (format (conversation-log-port) | |
81 | "conversation expecting pattern ~s~%" | |
82 | pattern)) | |
83 | ||
84 | (define-syntax converse | |
85 | (lambda (s) | |
86 | "Convert over PORT: read sexps from there, match them against each | |
87 | PATTERN, and send the corresponding REPLY. Raise to '&pattern-not-matched' | |
88 | when one of the PATTERNs is not matched." | |
89 | ||
90 | ;; XXX: Strings that appear in PATTERNs must be in the language the | |
91 | ;; installer is running in. In the future, we should add support to allow | |
92 | ;; writing English strings in PATTERNs and have the pattern matcher | |
93 | ;; automatically translate them. | |
94 | ||
95 | ;; Here we emulate 'pmatch' syntax on top of 'match'. This is ridiculous | |
96 | ;; but that's because 'pmatch' compares objects with 'eq?', making it | |
97 | ;; pretty useless, and it doesn't support ellipses and such. | |
98 | ||
99 | (define (quote-pattern s) | |
100 | ;; Rewrite the pattern S from pmatch style (a ,b) to match style like | |
101 | ;; ('a b). | |
102 | (with-ellipsis ::: | |
103 | (syntax-case s (unquote _ ...) | |
104 | ((unquote id) #'id) | |
105 | (_ #'_) | |
106 | (... #'...) | |
107 | (id | |
108 | (identifier? #'id) | |
109 | #''id) | |
110 | ((lst :::) (map quote-pattern #'(lst :::))) | |
111 | (pattern #'pattern)))) | |
112 | ||
113 | (define (match-pattern s) | |
114 | ;; Match one pattern without a guard. | |
115 | (syntax-case s () | |
116 | ((port (pattern reply) continuation) | |
117 | (with-syntax ((pattern (quote-pattern #'pattern))) | |
118 | #'(let ((pat 'pattern)) | |
119 | (converse-debug pat) | |
120 | (match (read port) | |
121 | (pattern | |
122 | (let ((data (call-with-values (lambda () reply) | |
123 | list))) | |
124 | (for-each (lambda (obj) | |
125 | (write obj port) | |
126 | (newline port)) | |
127 | data) | |
128 | (force-output port) | |
129 | (continuation port))) | |
130 | (sexp | |
131 | (pattern-error pat sexp)))))))) | |
132 | ||
133 | (syntax-case s () | |
134 | ((_ port (pattern reply) rest ...) | |
135 | (match-pattern #'(port (pattern reply) | |
136 | (lambda (port) | |
137 | (converse port rest ...))))) | |
138 | ((_ port (pattern guard reply) rest ...) | |
139 | #`(let ((skip? (not guard)) | |
140 | (next (lambda (p) | |
141 | (converse p rest ...)))) | |
142 | (if skip? | |
143 | (next port) | |
144 | #,(match-pattern #'(port (pattern reply) next))))) | |
145 | ((_ port) | |
146 | #t)))) | |
147 | ||
148 | (define* (choose-locale+keyboard port | |
149 | #:key | |
150 | (language "English") | |
151 | (location "Hong Kong") | |
152 | (timezone '("Europe" "Zagreb")) | |
153 | (keyboard | |
154 | '("English (US)" | |
155 | "English (intl., with AltGr dead keys)"))) | |
156 | "Converse over PORT with the guided installer to choose the specified | |
157 | LANGUAGE, LOCATION, TIMEZONE, and KEYBOARD." | |
158 | (converse port | |
159 | ((list-selection (title "Locale language") | |
160 | (multiple-choices? #f) | |
161 | (items _)) | |
162 | language) | |
163 | ((list-selection (title "Locale location") | |
164 | (multiple-choices? #f) | |
165 | (items _)) | |
166 | location) | |
167 | ((menu (title "GNU Guix install") | |
168 | (text _) | |
169 | (items (,guided _ ...))) ;"Guided graphical installation" | |
170 | guided) | |
171 | ((list-selection (title "Timezone") | |
172 | (multiple-choices? #f) | |
173 | (items _)) | |
174 | (first timezone)) | |
175 | ((list-selection (title "Timezone") | |
176 | (multiple-choices? #f) | |
177 | (items _)) | |
178 | (second timezone)) | |
179 | ((list-selection (title "Layout") | |
180 | (multiple-choices? #f) | |
181 | (items _)) | |
182 | (first keyboard)) | |
183 | ((list-selection (title "Variant") | |
184 | (multiple-choices? #f) | |
185 | (items _)) | |
186 | (second keyboard)))) | |
187 | ||
188 | (define* (enter-host-name+passwords port | |
189 | #:key | |
190 | (host-name "guix") | |
191 | (root-password "foo") | |
192 | (users '(("alice" "pass1") | |
193 | ("bob" "pass2") | |
194 | ("charlie" "pass3")))) | |
195 | "Converse over PORT with the guided installer to choose HOST-NAME, | |
196 | ROOT-PASSWORD, and USERS." | |
197 | (converse port | |
198 | ((input (title "Hostname") (text _) (default _)) | |
199 | host-name) | |
200 | ((input (title "System administrator password") (text _) (default _)) | |
201 | root-password) | |
202 | ((input (title "Password confirmation required") (text _) (default _)) | |
203 | root-password) | |
204 | ((add-users) | |
205 | (match users | |
206 | (((names passwords) ...) | |
207 | (map (lambda (name password) | |
208 | `(user (name ,name) (real-name ,(string-titlecase name)) | |
209 | (home-directory ,(string-append "/home/" name)) | |
210 | (password ,password))) | |
211 | names passwords)))))) | |
212 | ||
213 | (define* (choose-services port | |
214 | #:key | |
7a1a10db | 215 | (choose-desktop-environment? (const #f)) |
ccb1a8c4 LC |
216 | (choose-network-service? |
217 | (lambda (service) | |
218 | (or (string-contains service "SSH") | |
219 | (string-contains service "NSS")))) | |
220 | (choose-network-management-tool? | |
221 | (lambda (service) | |
222 | (string-contains service "DHCP")))) | |
223 | "Converse over PORT to choose networking services." | |
7a1a10db MO |
224 | (define desktop-environments '()) |
225 | ||
ccb1a8c4 LC |
226 | (converse port |
227 | ((checkbox-list (title "Desktop environment") (text _) | |
7a1a10db MO |
228 | (items ,services)) |
229 | (let ((desktops (filter choose-desktop-environment? services))) | |
230 | (set! desktop-environments desktops) | |
231 | desktops)) | |
ccb1a8c4 LC |
232 | ((checkbox-list (title "Network service") (text _) |
233 | (items ,services)) | |
234 | (filter choose-network-service? services)) | |
235 | ||
236 | ;; The "Network management" dialog shows up only when no desktop | |
237 | ;; environments have been selected, hence the guard. | |
238 | ((list-selection (title "Network management") | |
239 | (multiple-choices? #f) | |
240 | (items ,services)) | |
241 | (null? desktop-environments) | |
242 | (find choose-network-management-tool? services)))) | |
243 | ||
244 | (define (edit-configuration-file file) | |
245 | "Edit FILE, an operating system configuration file generated by the | |
246 | installer, by adding a marionette service such that the installed OS is | |
247 | instrumented for further testing." | |
248 | (define (read-expressions port) | |
249 | (let loop ((result '())) | |
250 | (match (read port) | |
251 | ((? eof-object?) | |
252 | (reverse result)) | |
253 | (exp | |
254 | (loop (cons exp result)))))) | |
255 | ||
256 | (define (edit exp) | |
257 | (match exp | |
258 | (('operating-system _ ...) | |
259 | `(marionette-operating-system ,exp | |
260 | #:imported-modules | |
261 | '((gnu services herd) | |
262 | (guix build utils) | |
263 | (guix combinators)))) | |
264 | (_ | |
265 | exp))) | |
266 | ||
267 | (let ((content (call-with-input-file file read-expressions))) | |
268 | (call-with-output-file file | |
269 | (lambda (port) | |
270 | (format port "\ | |
271 | ;; Operating system configuration edited for automated testing.~%~%") | |
272 | ||
273 | (pretty-print '(use-modules (gnu tests)) port) | |
274 | (for-each (lambda (exp) | |
275 | (pretty-print (edit exp) port) | |
276 | (newline port)) | |
277 | content))) | |
278 | ||
279 | #t)) | |
280 | ||
281 | (define* (choose-partitioning port | |
282 | #:key | |
283 | (encrypted? #t) | |
284 | (passphrase "thepassphrase") | |
285 | (edit-configuration-file | |
286 | edit-configuration-file)) | |
287 | "Converse over PORT to choose the partitioning method. When ENCRYPTED? is | |
288 | true, choose full-disk encryption with PASSPHRASE as the LUKS passphrase. | |
289 | This conversation goes past the final dialog box that shows the configuration | |
290 | file, actually starting the installation process." | |
291 | (converse port | |
292 | ((list-selection (title "Partitioning method") | |
293 | (multiple-choices? #f) | |
294 | (items (,not-encrypted ,encrypted _ ...))) | |
295 | (if encrypted? | |
296 | encrypted | |
297 | not-encrypted)) | |
298 | ((list-selection (title "Disk") (multiple-choices? #f) | |
475d4814 LC |
299 | (items (,disks ...))) |
300 | ;; When running the installation from an ISO image, the CD/DVD drive | |
301 | ;; shows up in the list. Avoid it. | |
302 | (find (lambda (disk) | |
303 | (not (or (string-contains disk "DVD") | |
304 | (string-contains disk "CD-ROM")))) | |
305 | disks)) | |
ccb1a8c4 LC |
306 | |
307 | ;; The "Partition table" dialog pops up only if there's not already a | |
308 | ;; partition table. | |
309 | ((list-selection (title "Partition table") | |
310 | (multiple-choices? #f) | |
311 | (items _)) | |
312 | "gpt") | |
313 | ((list-selection (title "Partition scheme") | |
314 | (multiple-choices? #f) | |
315 | (items (,one-partition _ ...))) | |
316 | one-partition) | |
317 | ((list-selection (title "Guided partitioning") | |
318 | (multiple-choices? #f) | |
319 | (items (,disk _ ...))) | |
320 | disk) | |
321 | ((input (title "Password required") | |
322 | (text _) (default #f)) | |
323 | encrypted? ;only when ENCRYPTED? | |
324 | passphrase) | |
325 | ((input (title "Password confirmation required") | |
326 | (text _) (default #f)) | |
327 | encrypted? | |
328 | passphrase) | |
329 | ((confirmation (title "Format disk?") (text _)) | |
330 | #t) | |
331 | ((info (title "Preparing partitions") _ ...) | |
332 | (values)) ;nothing to return | |
333 | ((file-dialog (title "Configuration file") | |
334 | (text _) | |
335 | (file ,configuration-file)) | |
336 | (edit-configuration-file configuration-file)))) | |
337 | ||
338 | (define (conclude-installation port) | |
339 | "Conclude the installation by checking over PORT that we get the final | |
340 | messages once the 'guix system init' process has completed." | |
341 | (converse port | |
342 | ((pause) ;"Press Enter to continue." | |
343 | #t) | |
344 | ((installation-complete) ;congratulations! | |
345 | (values)))) | |
346 | ||
347 | ;;; Local Variables: | |
348 | ;;; eval: (put 'converse 'scheme-indent-function 1) | |
349 | ;;; eval: (put 'with-ellipsis 'scheme-indent-function 1) | |
350 | ;;; End: |