projects/guix·blob kde-team · refs

353 lines · 13.3 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016-2020, 2022-2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2017 Mathieu Othacehe <[email protected]>
4;;; Copyright © 2017 Tobias Geerinckx-Rice <[email protected]>
5;;; Copyright © 2021 Maxime Devos <[email protected]>
6;;;
7;;; This file is part of GNU Guix.
8;;;
9;;; GNU Guix is free software; you can redistribute it and/or modify it
10;;; under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 3 of the License, or (at
12;;; your option) any later version.
13;;;
14;;; GNU Guix is distributed in the hope that it will be useful, but
15;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21
22(define-module (gnu tests)
23 #:use-module (guix gexp)
24 #:use-module (guix diagnostics)
25 #:use-module (guix records)
26 #:use-module ((guix ui) #:select (warn-about-load-error))
27 #:use-module (gnu bootloader)
28 #:use-module (gnu bootloader grub)
29 #:use-module (gnu system)
30 #:use-module (gnu system file-systems)
31 #:use-module (gnu system shadow)
32 #:use-module (gnu services)
33 #:use-module (gnu services base)
34 #:use-module (gnu services shepherd)
35 #:use-module (guix discovery)
36 #:use-module (guix monads)
37 #:use-module ((guix store) #:select (%store-monad store-parameterize))
38 #:use-module ((guix utils)
39 #:select (%current-system %current-target-system))
40 #:use-module (srfi srfi-1)
41 #:use-module (srfi srfi-9 gnu)
42 #:use-module (ice-9 match)
43 #:export (marionette-configuration
44 marionette-configuration?
45 marionette-configuration-device
46 marionette-configuration-imported-modules
47 marionette-configuration-requirements
48
49 marionette-service-type
50 marionette-operating-system
51 marionette-program
52 define-os-with-source
53
54 %simple-os
55 simple-operating-system
56 operating-system-with-console-syslog
57
58 system-test
59 system-test?
60 system-test-name
61 system-test-value
62 system-test-description
63 system-test-location
64
65 fold-system-tests
66 all-system-tests))
67
68;;; Commentary:
69;;;
70;;; This module provides the infrastructure to run operating system tests.
71;;; The most important part of that is tools to instrument the OS under test,
72;;; essentially allowing it to run in a virtual machine controlled by the host
73;;; system--hence the name "marionette".
74;;;
75;;; Code:
76
77(define %default-marionette-device
78 ;; Default marionette device in the guest.
79 "/dev/virtio-ports/org.gnu.guix.port.0")
80
81(define-record-type* <marionette-configuration>
82 marionette-configuration make-marionette-configuration
83 marionette-configuration?
84 (device marionette-configuration-device ;string
85 (default %default-marionette-device))
86 (imported-modules marionette-configuration-imported-modules
87 (default '()))
88 (extensions marionette-configuration-extensions
89 (default '())) ; list of packages
90 (requirements marionette-configuration-requirements ;list of symbols
91 (default '())))
92
93;; Hack: avoid indenting code beyond column 80 in marionette-shepherd-service.
94(define-syntax-rule (with-imported-modules-and-extensions imported-modules
95 extensions
96 gexp)
97 (with-imported-modules imported-modules
98 (with-extensions extensions
99 gexp)))
100
101(define* (marionette-program #:optional
102 (device %default-marionette-device)
103 (imported-modules '())
104 (extensions '()))
105 "Return the program that runs the marionette REPL on DEVICE. Ensure
106IMPORTED-MODULES and EXTENSIONS are accessible from the REPL."
107 (define code
108 (with-imported-modules-and-extensions
109 `((guix build utils)
110 (guix build syscalls)
111 ,@imported-modules)
112 extensions
113 #~(begin
114 (use-modules (ice-9 match)
115 (ice-9 binary-ports))
116
117 (define (self-quoting? x)
118 (letrec-syntax ((one-of (syntax-rules ()
119 ((_) #f)
120 ((_ pred rest ...)
121 (or (pred x)
122 (one-of rest ...))))))
123 (one-of symbol? string? keyword? pair? null? array?
124 number? boolean? char?)))
125
126 (let ((repl (open-file #$device "r+0"))
127 (console (open-file "/dev/console" "r+0")))
128 ;; Redirect output to the console.
129 (close-fdes 1)
130 (close-fdes 2)
131 (dup2 (fileno console) 1)
132 (dup2 (fileno console) 2)
133 (close-port console)
134
135 (display 'ready repl)
136 (let loop ()
137 (newline repl)
138
139 (match (read repl)
140 ((? eof-object?)
141 (primitive-exit 0))
142 (expr
143 (catch #t
144 (lambda ()
145 (let ((result (primitive-eval expr)))
146 (write (if (self-quoting? result)
147 result
148 (object->string result))
149 repl)))
150 (lambda (key . args)
151 (print-exception (current-error-port)
152 (stack-ref (make-stack #t) 1)
153 key args)
154 (write #f repl)))))
155 (loop))))))
156
157 (program-file "marionette-repl.scm" code))
158
159(define (marionette-shepherd-service config)
160 "Return the Shepherd service for the marionette REPL"
161 (match config
162 (($ <marionette-configuration> device imported-modules extensions
163 requirement)
164 (list (shepherd-service
165 (provision '(marionette))
166
167 ;; Always depend on UDEV so that DEVICE is available.
168 (requirement `(udev ,@requirement))
169
170 (modules '((ice-9 match)
171 (srfi srfi-9 gnu)))
172 (start #~(make-forkexec-constructor
173 (list #$(marionette-program device
174 imported-modules
175 extensions))))
176 (stop #~(make-kill-destructor)))))))
177
178(define marionette-service-type
179 ;; This is the type of the "marionette" service, allowing a guest system to
180 ;; be manipulated from the host. This marionette REPL is essentially a
181 ;; universal backdoor.
182 (service-type (name 'marionette-repl)
183 (extensions
184 (list (service-extension shepherd-root-service-type
185 marionette-shepherd-service)))
186 (description "The @dfn{marionette} service allows a guest
187system (virtual machine) to be manipulated by the host. It is used for system
188tests.")))
189
190(define* (marionette-operating-system os
191 #:key
192 (imported-modules '())
193 (extensions '())
194 (requirements '()))
195 "Return a marionetteed variant of OS such that OS can be used as a
196marionette in a virtual machine--i.e., controlled from the host system. The
197marionette service in the guest is started after the Shepherd services listed
198in REQUIREMENTS. The packages in the list EXTENSIONS are made available from
199the backdoor REPL."
200 (operating-system
201 (inherit os)
202 ;; Make sure the guest dies on error.
203 (kernel-arguments (cons "panic=1"
204 (operating-system-user-kernel-arguments os)))
205 ;; Make sure the guest doesn't hang in the REPL on error.
206 (initrd (lambda (fs . rest)
207 (apply (operating-system-initrd os) fs
208 #:on-error 'backtrace
209 rest)))
210 (services (cons (service marionette-service-type
211 (marionette-configuration
212 (requirements requirements)
213 (extensions extensions)
214 (imported-modules imported-modules)))
215 (operating-system-user-services os)))))
216
217(define-syntax define-os-with-source
218 (syntax-rules (use-modules operating-system)
219 "Define two variables: OS containing the given operating system, and
220SOURCE containing the source to define OS as an sexp.
221
222This is convenient when we need both the <operating-system> object so we can
223instantiate it, and the source to create it so we can store in in a file in
224the system under test."
225 ((_ (os source)
226 (use-modules modules ...)
227 (operating-system fields ...))
228 (begin
229 (define os
230 (operating-system fields ...))
231 (define source
232 '(begin
233 (use-modules modules ...)
234 (operating-system fields ...)))))))
235
236
237;;;
238;;; Simple operating systems.
239;;;
240
241(define %simple-os
242 (operating-system
243 (host-name "komputilo")
244 (timezone "Europe/Berlin")
245 (locale "en_US.UTF-8")
246
247 (bootloader (bootloader-configuration
248 (bootloader grub-bootloader)
249 (targets '("/dev/sdX"))))
250 (file-systems (cons (file-system
251 (device (file-system-label "my-root"))
252 (mount-point "/")
253 (type "ext4"))
254 %base-file-systems))
255 (kernel-arguments (delete "quiet" %default-kernel-arguments))
256 (firmware '())
257
258 (users (cons (user-account
259 (name "alice")
260 (comment "Bob's sister")
261 (group "users")
262 (supplementary-groups '("wheel" "audio" "video")))
263 %base-user-accounts))))
264
265(define-syntax-rule (simple-operating-system user-services ...)
266 "Return an operating system that includes USER-SERVICES in addition to
267%BASE-SERVICES."
268 (operating-system (inherit %simple-os)
269 (services (cons* user-services ... %base-services))))
270
271
272(define (operating-system-with-console-syslog os)
273 "Return OS with a system log service that writes to /dev/console."
274 (operating-system
275 (inherit os)
276 (services
277 (modify-services services
278 (shepherd-system-log-service-type
279 config
280 =>
281 (system-log-configuration
282 (inherit config)
283 (message-destination
284 #~(lambda (message)
285 (let ((destinations ((default-message-destination-procedure)
286 message)))
287 (if (<= (system-log-message-priority message)
288 (system-log-priority info))
289 (cons "/dev/console" destinations)
290 destinations))))))))))
291
292
293;;;
294;;; Tests.
295;;;
296
297(define-record-type* <system-test> system-test make-system-test
298 system-test?
299 (name system-test-name) ;string
300 (value system-test-value) ;%STORE-MONAD value
301 (description system-test-description) ;string
302 (location system-test-location (innate) ;<location>
303 (default (and=> (current-source-location)
304 source-properties->location))))
305
306(define (write-system-test test port)
307 (match test
308 (($ <system-test> name _ _ ($ <location> file line))
309 (format port "#<system-test ~a ~a:~a ~a>"
310 name file line
311 (number->string (object-address test) 16)))
312 (($ <system-test> name)
313 (format port "#<system-test ~a ~a>" name
314 (number->string (object-address test) 16)))))
315
316(set-record-type-printer! <system-test> write-system-test)
317
318(define-gexp-compiler (compile-system-test (test <system-test>)
319 system target)
320 "Compile TEST to a derivation."
321 (store-parameterize ((%current-system system)
322 (%current-target-system target))
323 (system-test-value test)))
324
325(define (test-modules)
326 "Return the list of modules that define system tests."
327 (scheme-modules (dirname (search-path %load-path "guix.scm"))
328 "gnu/tests"
329 #:warn warn-about-load-error))
330
331(define* (fold-system-tests proc init
332 #:optional
333 (modules (test-modules))
334 #:key (select? (const #t)))
335 "Invoke (PROC SYSTEST RESULT) on each system test, passing it the test and
336the previous result."
337 (fold-module-public-variables (lambda (obj result)
338 (if (and (system-test? obj) (select? obj))
339 (proc obj result)
340 result))
341 init
342 modules))
343
344(define (all-system-tests)
345 "Return the list of system tests."
346 (reverse (fold-system-tests cons '())))
347
348
349;; Local Variables:
350;; eval: (put 'with-imported-modules-and-extensions 'scheme-indent-function 2)
351;; End:
352
353;;; tests.scm ends here