projects/guix·blob master · refs

123 lines · 4.6 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2022⁠–⁠2023 Bruno Victal <[email protected]>.
3;;;
4;;; This file is part of GNU Guix.
5;;;
6;;; GNU Guix is free software; you can redistribute it and/or modify it
7;;; under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 3 of the License, or (at
9;;; your option) any later version.
10;;;
11;;; GNU Guix is distributed in the hope that it will be useful, but
12;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18
19(define-module (gnu tests gdm)
20 #:use-module (gnu tests)
21 #:use-module (gnu packages freedesktop)
22 #:use-module (gnu packages ocr)
23 #:use-module (gnu services)
24 #:use-module (gnu services desktop)
25 #:use-module (gnu services xorg)
26 #:use-module (gnu system)
27 #:use-module (gnu system vm)
28 #:use-module (guix gexp)
29 #:use-module (ice-9 format)
30 #:export (%test-gdm-x11
31 %test-gdm-wayland))
32
33(define* (make-os #:key wayland?)
34 (operating-system
35 (inherit %simple-os)
36 (services
37 (modify-services %desktop-services
38 (gdm-service-type config => (gdm-configuration
39 (inherit config)
40 (wayland? wayland?)))))))
41
42(define* (run-gdm-test #:key wayland?)
43 "Run tests in a vm which has gdm running."
44 (define os
45 (marionette-operating-system
46 (make-os #:wayland? wayland?)
47 #:imported-modules '((gnu services herd))))
48
49 (define vm
50 (virtual-machine
51 (operating-system os)
52 (memory-size 1024)))
53
54 (define name (format #f "gdm-~:[x11~;wayland~]" wayland?))
55
56 (define test
57 (with-imported-modules '((gnu build marionette))
58 #~(begin
59 (use-modules (gnu build marionette)
60 (ice-9 format)
61 (srfi srfi-26)
62 (srfi srfi-64))
63
64 (let ((marionette (make-marionette (list #$vm)))
65 (expected-session-type #$(if wayland? "wayland" "x11")))
66
67 (test-runner-current (system-test-runner #$output))
68 (test-begin #$name)
69
70 ;; service for gdm is called xorg-server
71 (test-assert "service is running"
72 (marionette-eval
73 '(begin
74 (use-modules (gnu services herd))
75 (start-service 'xorg-server))
76 marionette))
77
78 (test-group "gdm ready"
79 (test-assert "PID file present"
80 (wait-for-file "/var/run/gdm/gdm.pid" marionette))
81
82 ;; Waiting for gdm.pid is not enough, tests may still sporadically
83 ;; fail; ensure that the login screen is up.
84 ;; XXX: GNU Ocrad works but with '--invert' only.
85 (test-assert "login screen up"
86 (wait-for-screen-text marionette
87 (cut string-contains <> "Guix")
88 #:ocr #$(file-append ocrad "/bin/ocrad")
89 #:ocr-arguments '("--invert")
90 #:timeout 120))) ;for slow systems
91
92 (test-equal (string-append "session-type is " expected-session-type)
93 expected-session-type
94 (marionette-eval
95 '(begin
96 (use-modules (ice-9 popen)
97 (ice-9 rdelim))
98
99 (let* ((loginctl #$(file-append elogind "/bin/loginctl"))
100 (get-session-cmd (string-join `(,loginctl "show-user" "gdm"
101 "--property Display" "--value")))
102 (session (call-with-port (open-input-pipe get-session-cmd) read-line))
103 (get-type-cmd (string-join `(,loginctl "show-session" ,session
104 "--property Type" "--value")))
105 (type (call-with-port (open-input-pipe get-type-cmd) read-line)))
106 type))
107 marionette))
108
109 (test-end)))))
110
111 (gexp->derivation (string-append name "-test") test))
112
113(define %test-gdm-x11
114 (system-test
115 (name "gdm-x11")
116 (description "Basic tests for the GDM service. (X11)")
117 (value (run-gdm-test))))
118
119(define %test-gdm-wayland
120 (system-test
121 (name "gdm-wayland")
122 (description "Basic tests for the GDM service. (Wayland)")
123 (value (run-gdm-test #:wayland? #t))))