projects/guix·blob ruby-team · refs

345 lines · 12.7 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2017, 2021, 2023 Ludovic Courtès <[email protected]>
3;;; Copyright © 2021 muradm <[email protected]>
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 tests desktop)
21 #:use-module (gnu tests)
22 #:use-module (gnu packages shells)
23 #:use-module (gnu services)
24 #:use-module (gnu services base)
25 #:use-module (gnu services dbus)
26 #:use-module (gnu services desktop)
27 #:use-module (gnu system)
28 #:use-module (gnu system vm)
29 #:use-module (guix gexp)
30 #:use-module (srfi srfi-1)
31 #:export (%test-elogind
32 %test-minimal-desktop))
33
34
35;;;
36;;; Elogind.
37;;;
38
39(define (run-elogind-test vm)
40 (define test
41 (with-imported-modules '((gnu build marionette)
42 (guix build syscalls))
43 #~(begin
44 (use-modules (gnu build marionette)
45 (guix build syscalls)
46 (srfi srfi-64))
47
48 (define marionette
49 (make-marionette '(#$vm)))
50
51 (test-runner-current (system-test-runner #$output))
52 (test-begin "elogind")
53
54 ;; Log in as root on tty1, and check what 'loginctl' returns.
55 (test-equal "login on tty1"
56 '(("c1" "0" "root" "seat0" "tty1" "active" "no" "-") ;session
57 ("seat0") ;seat
58 ("0" "root" "no" "active")) ;user
59
60 (begin
61 ;; Wait for tty1.
62 (marionette-eval
63 '(begin
64 (use-modules (gnu services herd))
65 (start-service 'term-tty1)
66 (start-service 'elogind))
67 marionette)
68 (marionette-control "sendkey ctrl-alt-f1" marionette)
69
70 ;; Now we can type.
71 (marionette-type "root\n" marionette)
72 (marionette-type "loginctl list-users --no-legend > users\n"
73 marionette)
74 (marionette-type "loginctl list-seats --no-legend > seats\n"
75 marionette)
76 (marionette-type "loginctl list-sessions --no-legend > sessions\n"
77 marionette)
78
79
80 ;; Read the three files.
81 (marionette-eval '(use-modules (rnrs io ports)) marionette)
82 (let ((guest-file (lambda (file)
83 (string-tokenize
84 (wait-for-file file marionette
85 #:read 'get-string-all)))))
86 (list (guest-file "/root/sessions")
87 (guest-file "/root/seats")
88 (guest-file "/root/users")))))
89
90 (test-assert "screendump"
91 (begin
92 (let ((capture (string-append #$output "/tty1.ppm")))
93 (marionette-control
94 (string-append "screendump " capture) marionette)
95 (file-exists? capture))))
96
97 (test-end))))
98
99 (gexp->derivation "elogind" test))
100
101(define %test-elogind
102 (system-test
103 (name "elogind")
104 (description
105 "Test whether we can log in when elogind is enabled, and whether
106'loginctl' reports accurate user, session, and seat information.")
107 (value
108 (let ((os (marionette-operating-system
109 (simple-operating-system
110 (service elogind-service-type)
111 (service polkit-service-type)
112 (service dbus-root-service-type))
113 #:imported-modules '((gnu services herd)
114 (guix combinators)))))
115 (run-elogind-test (virtual-machine os))))))
116
117
118;;;
119;;; Seatd/greetd based minimal desktop
120;;;
121
122(define %minimal-services
123 (append
124 (modify-services %base-services
125 ;; greetd-service-type provides "greetd" PAM service
126 (delete login-service-type)
127 ;; and can be used in place of mingetty-service-type
128 (delete mingetty-service-type))
129 (list
130 (service seatd-service-type)
131 (service greetd-service-type
132 (greetd-configuration
133 (greeter-supplementary-groups '("input" "video"))
134 (terminals
135 (list
136 ;; we can make any terminal active by default
137 (greetd-terminal-configuration (terminal-vt "1") (terminal-switch #t))
138 ;; we can make environment without XDG_RUNTIME_DIR set
139 ;; even provide our own environment variables
140 (greetd-terminal-configuration
141 (terminal-vt "2")
142 (default-session-command
143 (greetd-agreety-session
144 (command
145 (greetd-user-session
146 (extra-env '(("MY_VAR" . "1")))
147 (xdg-env? #f))))))
148 ;; we can use different shell instead of default bash
149 (greetd-terminal-configuration
150 (terminal-vt "3")
151 (default-session-command
152 (greetd-agreety-session
153 (command
154 (greetd-user-session
155 (command (file-append zsh "/bin/zsh"))
156 (command-args '("-l"))
157 (extra-env '(("MY_VAR" . "1")))
158 (xdg-env? #f))))))
159 ;; we can use any other executable command as greeter
160 (greetd-terminal-configuration
161 (terminal-vt "4")
162 (default-session-command (program-file "my-noop-greeter" #~(exit))))
163 (greetd-terminal-configuration (terminal-vt "5"))
164 (greetd-terminal-configuration (terminal-vt "6"))))))
165 ;; mingetty-service-type can be used in parallel
166 ;; if needed to do so, do not (delete login-service-type)
167 ;; as illustrated above
168 #| (service mingetty-service-type (mingetty-configuration (tty "tty8"))) |#)))
169
170(define-syntax-rule (minimal-operating-system user-services ...)
171 "Return an operating system that includes USER-SERVICES in addition to
172minimal %BASE-SERVICES."
173 (operating-system (inherit %simple-os)
174 (services (cons* user-services ... %minimal-services))))
175
176(define (run-minimal-desktop-test os vm)
177 (define test
178 (with-imported-modules '((gnu build marionette)
179 (guix build syscalls))
180 #~(begin
181 (use-modules (gnu build marionette)
182 (guix build syscalls)
183 (srfi srfi-1)
184 (srfi srfi-64)
185 (ice-9 pretty-print))
186
187 (define marionette
188 (make-marionette #$vm))
189
190 (define (file-get-all-strings fname)
191 (marionette-eval '(use-modules (rnrs io ports)) marionette)
192 (wait-for-file fname marionette #:read 'get-string-all))
193
194 (define (wait-for-unix-socket-m socket)
195 (wait-for-unix-socket socket marionette))
196
197 (mkdir #$output)
198 (chdir #$output)
199
200 (test-runner-current (system-test-runner #$output))
201 (test-begin "minimal-desktop")
202
203 (test-assert "seatd is ready"
204 (wait-for-unix-socket-m "/run/seatd.sock"))
205
206 (test-equal "login user on tty1"
207 "alice\n"
208 (begin
209 ;; Wait for tty1.
210 (marionette-eval
211 '(begin
212 (use-modules (gnu services herd))
213 (start-service 'term-tty1))
214 marionette)
215 (marionette-control "sendkey ctrl-alt-f1" marionette)
216
217 ;; login as root change alice password and exit
218 ;; then login as alice
219 (for-each
220 (lambda (cmd) (marionette-type cmd marionette) (sleep 1))
221 (list
222 "root\n"
223 "passwd alice\n"
224 "alice\n"
225 "alice\n"
226 "exit\n"
227 "alice\n"
228 "alice\n"
229 "id -un > logged-in\n"))
230
231 (file-get-all-strings "/home/alice/logged-in")))
232
233 (test-equal "validate user environment"
234 '("SEATD_SOCK=/run/seatd.sock"
235 "XDG_RUNTIME_DIR=/run/user/1000"
236 "XDG_SEAT=seat0"
237 "XDG_VTNR=1")
238
239 (begin
240 (marionette-type "env > env\n" marionette)
241 (sleep 1)
242
243 (define user-env (string-tokenize
244 (file-get-all-strings "/home/alice/env")))
245
246 (define (expected-var var)
247 (any (lambda (s) (string-contains var s))
248 '("SEATD_SOCK"
249 "XDG_RUNTIME_DIR"
250 "XDG_SEAT"
251 "XDG_VTNR")))
252
253 (sort (filter expected-var user-env) string<?)))
254
255 (test-assert "validate SEATD_SOCK"
256 (begin
257 (marionette-type "env > env\n" marionette)
258 (sleep 1)
259
260 (define (sock-var? var)
261 (any (lambda (s) (string-contains var s))
262 '("SEATD_SOCK")))
263
264 (define (sock-var-sock var)
265 (car (cdr (string-split var #\=))))
266
267 (let*
268 ((out (file-get-all-strings "/home/alice/env"))
269 (out (string-tokenize out))
270 (out (filter sock-var? out))
271 (socks (map sock-var-sock out))
272 (socks (map wait-for-unix-socket-m socks)))
273 (and (= 1 (length socks)) (every identity socks)))))
274
275 (test-equal "seatd.sock ownership"
276 '("root" "seat")
277 `(,(marionette-eval
278 '(passwd:name (getpwuid (stat:uid (stat "/run/seatd.sock"))))
279 marionette)
280 ,(marionette-eval
281 '(group:name (getgrgid (stat:gid (stat "/run/seatd.sock"))))
282 marionette)))
283
284 (test-assert "greetd is ready"
285 (begin
286 (marionette-type "ps -C greetd -o pid,args --no-headers > ps-greetd\n"
287 marionette)
288 (sleep 1)
289
290 (define (greetd-daemon? cmd)
291 (string-contains cmd "config"))
292
293 (define (greetd-cmd-to-pid cmd)
294 (car (string-split cmd #\space)))
295
296 (define (greetd-pid-to-sock pid)
297 (string-append "/run/greetd-" pid ".sock"))
298
299 (let* ((out (file-get-all-strings "/home/alice/ps-greetd"))
300 (out (string-split out #\newline))
301 (out (map string-trim-both out))
302 (out (filter greetd-daemon? out))
303 (pids (map greetd-cmd-to-pid out))
304 (socks (map greetd-pid-to-sock pids))
305 (socks (map wait-for-unix-socket-m socks)))
306 (every identity socks))))
307
308 ;; a bit weak, but tests everything at once actually
309 (test-equal "check /run/user/<uid> mounted and writable"
310 "alice\n"
311 (begin
312 (marionette-type "echo alice > /run/user/1000/test\n" marionette)
313 (file-get-all-strings "/run/user/1000/test")))
314
315 (test-equal "check greeter user has correct groups"
316 "greeter input video\n"
317 (begin
318 (marionette-type "id -Gn greeter > /run/user/1000/greeter-groups\n"
319 marionette)
320 (file-get-all-strings "/run/user/1000/greeter-groups")))
321
322 (test-assert "screendump"
323 (begin
324 (marionette-control (string-append "screendump " #$output
325 "/tty1.ppm")
326 marionette)
327 (file-exists? "tty1.ppm")))
328
329 (test-end))))
330
331 (gexp->derivation "minimal-desktop" test))
332
333(define %test-minimal-desktop
334 (system-test
335 (name "minimal-desktop")
336 (description
337 "Test whether we can log in when seatd and greetd is enabled")
338 (value
339 (let* ((os (marionette-operating-system
340 (minimal-operating-system)
341 #:imported-modules '((gnu services herd)
342 (guix combinators))))
343 (vm (virtual-machine os)))
344 (run-minimal-desktop-test (virtualized-operating-system os '())
345 #~(list #$vm))))))