projects/guix·blob kernel-updates · refs

415 lines · 15.3 KiB

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