diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/local.mk | 1 | ||||
| -rw-r--r-- | gnu/services/lightdm.scm | 687 | ||||
| -rw-r--r-- | gnu/tests/lightdm.scm | 160 |
3 files changed, 848 insertions, 0 deletions
diff --git a/gnu/local.mk b/gnu/local.mk index a9aebe5193..b67dfac4e7 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -661,6 +661,7 @@ GNU_SYSTEM_MODULES = \ %D%/services/guix.scm \ %D%/services/hurd.scm \ %D%/services/kerberos.scm \ + %D%/services/lightdm.scm \ %D%/services/linux.scm \ %D%/services/lirc.scm \ %D%/services/virtualization.scm \ diff --git a/gnu/services/lightdm.scm b/gnu/services/lightdm.scm new file mode 100644 index 0000000000..07f2e808dd --- /dev/null +++ b/gnu/services/lightdm.scm @@ -0,0 +1,687 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019, 2020 L p R n d n <guix@lprndn.info> +;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services lightdm) + #:use-module (gnu artwork) + #:use-module (gnu packages admin) + #:use-module (gnu packages display-managers) + #:use-module (gnu packages freedesktop) + #:use-module (gnu packages gnome) + #:use-module (gnu packages vnc) + #:use-module (gnu packages xorg) + #:use-module (gnu services configuration) + #:use-module (gnu services dbus) + #:use-module (gnu services desktop) + #:use-module (gnu services shepherd) + #:use-module (gnu services xorg) + #:use-module (gnu services) + #:use-module (gnu system pam) + #:use-module (gnu system shadow) + #:use-module (guix diagnostics) + #:use-module (guix gexp) + #:use-module (guix i18n) + #:use-module (guix records) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (lightdm-seat-configuration + lightdm-seat-configuration? + lightdm-seat-configuration-name + lightdm-seat-configuration-type + lightdm-seat-configuration-user-session + lightdm-seat-configuration-autologin-user + lightdm-seat-configuration-greeter-session + lightdm-seat-configuration-xserver-command + lightdm-seat-configuration-session-wrapper + lightdm-seat-configuration-extra-config + + lightdm-gtk-greeter-configuration + lightdm-gtk-greeter-configuration? + lightdm-gtk-greeter-configuration-lightdm-gtk-greeter + lightdm-gtk-greeter-configuration-assets + lightdm-gtk-greeter-configuration-theme-name + lightdm-gtk-greeter-configuration-icon-theme-name + lightdm-gtk-greeter-configuration-cursor-theme-name + lightdm-gtk-greeter-configuration-allow-debug + lightdm-gtk-greeter-configuration-background + lightdm-gtk-greeter-configuration-a11y-states + lightdm-gtk-greeter-configuration-reader + lightdm-gtk-greeter-configuration-extra-config + + lightdm-configuration + lightdm-configuration? + lightdm-configuration-lightdm + lightdm-configuration-allow-empty-passwords? + lightdm-configuration-xorg-configuration + lightdm-configuration-greeters + lightdm-configuration-seats + lightdm-configuration-xdmcp? + lightdm-configuration-xdmcp-listen-address + lightdm-configuration-vnc-server? + lightdm-configuration-vnc-server-command + lightdm-configuration-vnc-server-listen-address + lightdm-configuration-vnc-server-port + lightdm-configuration-extra-config + + lightdm-service-type)) + +;;; +;;; Greeters. +;;; + +(define list-of-file-likes? + (list-of file-like?)) + +(define %a11y-states '(contrast font keyboard reader)) + +(define (a11y-state? value) + (memq value %a11y-states)) + +(define list-of-a11y-states? + (list-of a11y-state?)) + +(define-maybe boolean) + +(define (serialize-boolean name value) + (define (strip-trailing-? name) + ;; field? -> field + (let ((str (symbol->string name))) + (if (string-suffix? "?" str) + (string-drop-right str 1) + str))) + (format #f "~a=~:[false~;true~]~%" (strip-trailing-? name) value)) + +(define-maybe file-like) + +(define (serialize-file-like name value) + #~(format #f "~a=~a~%" '#$name #$value)) + +(define (serialize-list-of-a11y-states name value) + (format #f "~a=~a~%" name (string-join (map symbol->string value) ";"))) + +(define (serialize-string name value) + (format #f "~a=~a~%" name value)) + +(define (serialize-number name value) + (format #f "~a=~a~%" name value)) + +(define (serialize-list-of-strings _ value) + (string-join value "\n")) + +(define-configuration lightdm-gtk-greeter-configuration + (lightdm-gtk-greeter + (file-like lightdm-gtk-greeter) + "The lightdm-gtk-greeter package to use." + empty-serializer) + (assets + (list-of-file-likes (list adwaita-icon-theme + gnome-themes-extra + ;; FIXME: hicolor-icon-theme should be in the + ;; packages of the desktop templates. + hicolor-icon-theme)) + "The list of packages complementing the greeter, such as package providing +icon themes." + empty-serializer) + (theme-name + (string "Adwaita") + "The name of the theme to use.") + (icon-theme-name + (string "Adwaita") + "The name of the icon theme to use.") + (cursor-theme-name + (string "Adwaita") + "The name of the cursor theme to use.") + (cursor-theme-size + (number 16) + "The size to use for the the cursor theme.") + (allow-debugging? + maybe-boolean + "Set to #t to enable debug log level.") + (background + (file-like (file-append %artwork-repository + "/backgrounds/guix-checkered-16-9.svg")) + "The background image to use.") + ;; FIXME: This should be enabled by default, but it currently doesn't work, + ;; failing to connect to D-Bus, causing the login to fail. + (at-spi-enabled? + (boolean #f) + "Enable accessibility support through the Assistive Technology Service +Provider Interface (AT-SPI).") + (a11y-states + (list-of-a11y-states %a11y-states) + "The accessibility features to enable, given as list of symbols.") + (reader + maybe-file-like + "The command to use to launch a screen reader.") + (extra-config + (list-of-strings '()) + "Extra configuration values to append to the LightDM GTK Greeter +configuration file.")) + +(define (strip-class-name-brackets name) + "Remove the '<<' and '>>' brackets from NAME, a symbol." + (let ((name* (symbol->string name))) + (if (and (string-prefix? "<<" name*) + (string-suffix? ">>" name*)) + (string->symbol (string-drop (string-drop-right name* 2) 2)) + (error "unexpected class name" name*)))) + +(define (config->name config) + "Return the constructor name (a symbol) from CONFIG." + (strip-class-name-brackets (class-name (class-of config)))) + +(define (greeter-configuration->greeter-fields config) + "Return the fields of CONFIG, a greeter configuration." + (match config + ;; Note: register any new greeter configuration here. + ((? lightdm-gtk-greeter-configuration?) + lightdm-gtk-greeter-configuration-fields))) + +(define (greeter-configuration->packages config) + "Return the list of greeter packages, including assets, used by CONFIG, a +greeter configuration." + (match config + ;; Note: register any new greeter configuration here. + ((? lightdm-gtk-greeter-configuration?) + (cons (lightdm-gtk-greeter-configuration-lightdm-gtk-greeter config) + (lightdm-gtk-greeter-configuration-assets config))))) + +;;; TODO: Implement directly in (gnu services configuration), perhaps by +;;; making the FIELDS argument optional. +(define (serialize-configuration* config) + "Like `serialize-configuration', but not requiring to provide a FIELDS +argument." + (define fields (greeter-configuration->greeter-fields config)) + (serialize-configuration config fields)) + +(define (greeter-configuration->conf-name config) + "Return the file name of CONFIG, a greeter configuration." + (format #f "~a.conf" (greeter-configuration->greeter-session config))) + +(define (greeter-configuration->file config) + "Serialize CONFIG into a file under the output directory, so that it can be +easily added to XDG_CONF_DIRS." + (computed-file + (greeter-configuration->conf-name config) + #~(begin + (call-with-output-file #$output + (lambda (port) + (format port (string-append + "[greeter]\n" + #$(serialize-configuration* config)))))))) + + +;;; +;;; Seats. +;;; + +(define seat-name? string?) + +(define (serialize-seat-name _ value) + (format #f "[Seat:~a]~%" value)) + +(define (seat-type? type) + (memq type '(local xremote))) + +(define (serialize-seat-type name value) + (format #f "~a=~a~%" name value)) + +(define-maybe seat-type) + +(define (greeter-session? value) + (memq value '(lightdm-gtk-greeter))) + +(define (serialize-greeter-session name value) + (format #f "~a=~a~%" name value)) + +(define-maybe greeter-session) + +(define-maybe string) + +;;; Note: all the fields except for the seat name should be 'maybe's, since +;;; the real default value is set by the %lightdm-seat-default define later, +;;; and this avoids repeating ourselves in the serialized configuration file. +(define-configuration lightdm-seat-configuration + (name + seat-name + "The name of the seat. An asterisk (*) can be used in the name +to apply the seat configuration to all the seat names it matches.") + (user-session + maybe-string + "The session to use by default. The session name must be provided as a +lowercase string, such as @code{\"gnome\"}, @code{\"ratpoison\"}, etc.") + (type + (seat-type 'local) + "The type of the seat, either the @code{local} or @code{xremote} symbol.") + (autologin-user + maybe-string + "The username to automatically log in with by default.") + (greeter-session + (greeter-session 'lightdm-gtk-greeter) + "The greeter session to use, specified as a symbol. Currently, only +@code{lightdm-gtk-greeter} is supported.") + ;; Note: xserver-command must be lazily computed, so that it can be + ;; overridden via 'lightdm-configuration-xorg-configuration'. + (xserver-command + maybe-file-like + "The Xorg server command to run.") + (session-wrapper + (file-like (xinitrc)) + "The xinitrc session wrapper to use.") + (extra-config + (list-of-strings '()) + "Extra configuration values to append to the seat configuration section.")) + +(define (greeter-session->greater-configuration-pred identifier) + "Return the predicate to check if a configuration is of the type specifying +a greeter identified by IDENTIFIER." + (match identifier + ;; Note: register any new greeter identifier here. + ('lightdm-gtk-greeter + lightdm-gtk-greeter-configuration?))) + +(define (greeter-configuration->greeter-session config) + "Given CONFIG, a greeter configuration object, return its identifier, +a symbol." + (let ((suffix "-configuration") + (greeter-conf-name (config->name config))) + (string->symbol (string-drop-right (symbol->string greeter-conf-name) + (string-length suffix))))) + +(define list-of-seat-configurations? + (list-of lightdm-seat-configuration?)) + + +;;; +;;; LightDM. +;;; + +(define (greeter-configuration? config) + (or (lightdm-gtk-greeter-configuration? config) + ;; Note: register any new greeter configuration here. + )) + +(define (list-of-greeter-configurations? greeter-configs) + (and ((list-of greeter-configuration?) greeter-configs) + ;; Greeter configurations must also not be provided more than once. + (let* ((types (map (cut (compose class-name class-of) <>) + greeter-configs)) + (dupes (filter (lambda (type) + (< 1 (count (cut eq? type <>) types))) + types))) + (unless (null? dupes) + (leave (G_ "duplicate greeter configurations: ~a~%") dupes))))) + +(define-configuration/no-serialization lightdm-configuration + (lightdm + (file-like lightdm) + "The lightdm package to use.") + (allow-empty-passwords? + (boolean #f) + "Whether users not having a password set can login.") + (debug? + (boolean #f) + "Enable verbose output.") + (xorg-configuration + (xorg-configuration (xorg-configuration)) + "The default Xorg server configuration to use to generate the Xorg server +start script. It can be refined per seat via the @code{xserver-command} of +the @code{<lightdm-seat-configuration>} record, if desired.") + (greeters + (list-of-greeter-configurations (list (lightdm-gtk-greeter-configuration))) + "The LightDM greeter configurations specifying the greeters to use.") + (seats + (list-of-seat-configurations (list (lightdm-seat-configuration + (name "*")))) + "The seat configurations to use. A LightDM seat is akin to a user.") + (xdmcp? + (boolean #f) + "Whether a XDMCP server should listen on port UDP 177.") + (xdmcp-listen-address + maybe-string + "The host or IP address the XDMCP server listens for incoming connections. +When unspecified, listen on for any hosts/IP addresses.") + (vnc-server? + (boolean #f) + "Whether a VNC server is started.") + (vnc-server-command + (file-like (file-append tigervnc-server "bin/Xvnc")) + "The Xvnc command to use for the VNC server, it's possible to provide extra +options not otherwise exposed along the command, for example to disable +security: +@lisp +(vnc-server-command + (file-append tigervnc-server \"/bin/Xvnc\" + \" -SecurityTypes None\" )) +@end lisp + +Or to set a PasswordFile for the classic (unsecure) VncAuth mecanism: +@lisp +(vnc-server-command + (file-append tigervnc-server \"/bin/Xvnc\" + \" -PasswordFile /var/lib/lightdm/.vnc/passwd\")) +@end lisp +The password file should be manually created using the @command{vncpasswd} +command. + +Note that LightDM will create new sessions for VNC users, which means they +need to authenticate in the same way as local users would. +") + (vnc-server-listen-address + maybe-string + "The host or IP address the VNC server listens for incoming connections. +When unspecified, listen for any hosts/IP addresses.") + (vnc-server-port + (number 5900) + "The TCP port the VNC server should listen to.") + (extra-config + (list-of-strings '()) + "Extra configuration values to append to the LightDM configuration file.")) + +(define (lightdm-configuration->greeters-config-dir config) + "Return a directory containing all the serialized greeter configurations +from CONFIG, a <lightdm-configuration> object." + (file-union "etc-lightdm" + (append-map (lambda (g) + `((,(greeter-configuration->conf-name g) + ,(greeter-configuration->file g)))) + (lightdm-configuration-greeters config)))) + +(define (lightdm-configuration->packages config) + "Return all the greeter packages and their assets defined in CONFIG, a +<lightdm-configuration> object, as well as the lightdm package itself." + (cons (lightdm-configuration-lightdm config) + (append-map greeter-configuration->packages + (lightdm-configuration-greeters config)))) + +(define (validate-lightdm-configuration config) + "Sanity check CONFIG, a <lightdm-configuration> record instance." + ;; This is required to make inter-field validations, such as between the + ;; seats and greeters. + (let* ((seats (lightdm-configuration-seats config)) + (greeter-sessions (delete-duplicates + (map lightdm-seat-configuration-greeter-session + seats) + eq?)) + (greeter-configurations (lightdm-configuration-greeters config)) + (missing-greeters + (filter-map + (lambda (id) + (define pred (greeter-session->greater-configuration-pred id)) + (if (find pred greeter-configurations) + #f ;happy path + id)) + greeter-sessions))) + (unless (null? missing-greeters) + (leave (G_ "no greeter configured for seat greeter sessions: ~a~%") + missing-greeters)))) + +(define (lightdm-configuration-file config) + (match-record config <lightdm-configuration> + (xorg-configuration seats + xdmcp? xdmcp-listen-address + vnc-server? vnc-server-command vnc-server-listen-address vnc-server-port + extra-config) + (apply + mixed-text-file + "lightdm.conf" " +# +# General configuration +# +[LightDM] +greeter-user=lightdm +sessions-directory=/run/current-system/profile/share/xsessions\ +:/run/current-system/profile/share/wayland-sessions +remote-sessions-directory=/run/current-system/profile/share/remote-sessions +" + #~(string-join '#$extra-config "\n") + " +# +# XDMCP Server configuration +# +[XDMCPServer] +enabled=" (if xdmcp? "true" "false") "\n" +(if (maybe-value-set? xdmcp-listen-address) + (format #f "xdmcp-listen-address=~a" xdmcp-listen-address) + "") " + +# +# VNC Server configuration +# +[VNCServer] +enabled=" (if vnc-server? "true" "false") " +command=" vnc-server-command " +port=" (number->string vnc-server-port) "\n" +(if (maybe-value-set? vnc-server-listen-address) + (format #f "vnc-server-listen-address=~a" vnc-server-listen-address) + "") " + +# +# Seat configuration. +# +" + (map (lambda (seat) + ;; This complication exists to propagate a default value for + ;; the 'xserver-command' field of the seats. Having a + ;; 'xorg-configuration' field at the root of the + ;; lightdm-configuration enables the use of + ;; 'set-xorg-configuration' and can be more convenient. + (let ((seat* (if (maybe-value-set? + (lightdm-seat-configuration-xserver-command seat)) + seat + (lightdm-seat-configuration + (inherit seat) + (xserver-command (xorg-start-command + xorg-configuration)))))) + (serialize-configuration seat* + lightdm-seat-configuration-fields))) + seats)))) + +(define %lightdm-accounts + (list (user-group (name "lightdm") (system? #t)) + (user-account + (name "lightdm") + (group "lightdm") + (system? #t) + (comment "LightDM user") + (home-directory "/var/lib/lightdm") + (shell (file-append shadow "/sbin/nologin"))))) + +(define %lightdm-activation + ;; Ensure /var/lib/lightdm is owned by the "lightdm" user. Adapted from the + ;; %gdm-activation. + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define (ensure-ownership directory) + (let* ((lightdm (getpwnam "lightdm")) + (uid (passwd:uid lightdm)) + (gid (passwd:gid lightdm)) + (st (stat directory #f))) + ;; Recurse into directory only if it has wrong ownership. + (when (and st + (or (not (= uid (stat:uid st))) + (not (= gid (stat:gid st))))) + (for-each (lambda (file) + (chown file uid gid)) + (find-files "directory" + #:directories? #t))))) + + (when (not (stat "/var/lib/lightdm-data" #f)) + (mkdir-p "/var/lib/lightdm-data")) + (for-each ensure-ownership + '("/var/lib/lightdm" + "/var/lib/lightdm-data"))))) + +(define (lightdm-pam-service config) + "Return a PAM service for @command{lightdm}." + (unix-pam-service "lightdm" + #:login-uid? #t + #:allow-empty-passwords? + (lightdm-configuration-allow-empty-passwords? config))) + +(define (lightdm-greeter-pam-service) + "Return a PAM service for @command{lightdm-greeter}." + (pam-service + (name "lightdm-greeter") + (auth (list + ;; Load environment from /etc/environment and ~/.pam_environment. + (pam-entry (control "required") (module "pam_env.so")) + ;; Always let the greeter start without authentication. + (pam-entry (control "required") (module "pam_permit.so")))) + ;; No action required for account management + (account (list (pam-entry (control "required") (module "pam_permit.so")))) + ;; Prohibit changing password. + (password (list (pam-entry (control "required") (module "pam_deny.so")))) + ;; Setup session. + (session (list (pam-entry (control "required") (module "pam_unix.so")))))) + +(define (lightdm-autologin-pam-service) + "Return a PAM service for @command{lightdm-autologin}}." + (pam-service + (name "lightdm-autologin") + (auth + (list + ;; Block login if user is globally disabled. + (pam-entry (control "required") (module "pam_nologin.so")) + (pam-entry (control "required") (module "pam_succeed_if.so") + (arguments (list "uid >= 1000"))) + ;; Allow access without authentication. + (pam-entry (control "required") (module "pam_permit.so")))) + ;; Stop autologin if account requires action. + (account (list (pam-entry (control "required") (module "pam_unix.so")))) + ;; Prohibit changing password. + (password (list (pam-entry (control "required") (module "pam_deny.so")))) + ;; Setup session. + (session (list (pam-entry (control "required") (module "pam_unix.so")))))) + +(define (lightdm-pam-services config) + (list (lightdm-pam-service config) + (lightdm-greeter-pam-service) + (lightdm-autologin-pam-service))) + +(define (lightdm-shepherd-service config) + "Return a <lightdm-service> for LightDM using CONFIG." + + (validate-lightdm-configuration config) + + (define lightdm-command + #~(list #$(file-append (lightdm-configuration-lightdm config) + "/sbin/lightdm") + #$@(if (lightdm-configuration-debug? config) + #~("--debug") + #~()) + "--config" + #$(lightdm-configuration-file config))) + + (define lightdm-paths + (let ((lightdm (lightdm-configuration-lightdm config))) + #~(string-join + '#$(map (lambda (dir) + (file-append lightdm dir)) + '("/bin" "/sbin" "/libexec")) + ":"))) + + (define greeters-config-dir + (lightdm-configuration->greeters-config-dir config)) + + (define data-dirs + ;; LightDM itself needs to be in XDG_DATA_DIRS for the accountsservice + ;; interface it provides to be picked up. The greeters must also be in + ;; XDG_DATA_DIRS to be found. + (let ((packages (lightdm-configuration->packages config))) + #~(string-join '#$(map (cut file-append <> "/share") packages) + ":"))) + + (list + (shepherd-service + (documentation "LightDM display manager") + (requirement '(dbus-system user-processes host-name)) + (provision '(lightdm display-manager xorg-server)) + (respawn? #f) + (start + #~(lambda () + ;; Note: sadly, environment variables defined for 'lightdm' are + ;; cleared and/or overridden by /etc/profile by its spawned greeters, + ;; so an out-of-band means such as /etc is required. + (fork+exec-command #$lightdm-command + ;; Lightdm needs itself in its PATH. + #:environment-variables + (list + ;; It knows to look for greeter configurations in + ;; XDG_CONFIG_DIRS... + (string-append "XDG_CONFIG_DIRS=" + #$greeters-config-dir) + ;; ... and for greeter .desktop files as well as + ;; lightdm accountsservice interface in + ;; XDG_DATA_DIRS. + (string-append "XDG_DATA_DIRS=" + #$data-dirs) + (string-append "PATH=" #$lightdm-paths))))) + (stop #~(make-kill-destructor))))) + +(define lightdm-service-type + (handle-xorg-configuration + lightdm-configuration + (service-type + (name 'lightdm) + (default-value (lightdm-configuration)) + (extensions + (list (service-extension pam-root-service-type lightdm-pam-services) + (service-extension shepherd-root-service-type + lightdm-shepherd-service) + (service-extension activation-service-type + (const %lightdm-activation)) + (service-extension dbus-root-service-type + (compose list lightdm-configuration-lightdm)) + (service-extension polkit-service-type + (compose list lightdm-configuration-lightdm)) + (service-extension account-service-type + (const %lightdm-accounts)) + ;; Add 'lightdm' to the system profile, so that its + ;; 'share/accountsservice' D-Bus service extension directory can be + ;; found via the 'XDG_DATA_DIRS=/run/current-system/profile/share' + ;; environment variable set in the wrapper of the + ;; libexec/accounts-daemon binary of the accountsservice package. + ;; This daemon is spawned by D-Bus, and there's little we can do to + ;; affect its environment. For more reading, see: + ;; https://github.com/NixOS/nixpkgs/issues/45059. + (service-extension profile-service-type + lightdm-configuration->packages) + ;; This is needed for the greeter itself to find its configuration, + ;; because XDG_CONF_DIRS gets overridden by /etc/profile. + (service-extension + etc-service-type + (lambda (config) + `(("lightdm" + ,(lightdm-configuration->greeters-config-dir config))))))) + (description "Run @code{lightdm}, the LightDM graphical login manager.")))) + + +;;; +;;; Generate documentation. +;;; +(define (generate-doc) + (configuration->documentation 'lightdm-configuration) + (configuration->documentation 'lightdm-gtk-greeter-configuration) + (configuration->documentation 'lightdm-seat-configuration)) diff --git a/gnu/tests/lightdm.scm b/gnu/tests/lightdm.scm new file mode 100644 index 0000000000..431b388e7e --- /dev/null +++ b/gnu/tests/lightdm.scm @@ -0,0 +1,160 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>. +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu tests lightdm) + #:use-module (gnu bootloader) + #:use-module (gnu bootloader grub) + #:use-module (gnu packages) + #:use-module (gnu packages ocr) + #:use-module (gnu packages ratpoison) + #:use-module (gnu packages vnc) + #:use-module (gnu packages xorg) + #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu services dbus) + #:use-module (gnu services desktop) + #:use-module (gnu services networking) + #:use-module (gnu services lightdm) + #:use-module (gnu services ssh) + #:use-module (gnu services xorg) + #:use-module (gnu system) + #:use-module (gnu system file-systems) + #:use-module (gnu system shadow) + #:use-module (gnu system vm) + #:use-module (gnu tests) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (srfi srfi-1) + #:export (%test-lightdm)) + +(define minimal-desktop-services + (list polkit-wheel-service + (service upower-service-type) + (accountsservice-service) + (service polkit-service-type) + (elogind-service) + (dbus-service) + x11-socket-directory-service)) + +(define %lightdm-os + (operating-system + (inherit %simple-os) + (packages (cons* ocrad ratpoison xterm %base-packages)) + (services + (cons* (service lightdm-service-type + (lightdm-configuration + (allow-empty-passwords? #t) + (debug? #t) + (xdmcp? #t) + (vnc-server? #t) + (vnc-server-command + (file-append tigervnc-server "/bin/Xvnc" + " -SecurityTypes None")) + (greeters (list (lightdm-gtk-greeter-configuration + (allow-debugging? #t)))) + (seats (list (lightdm-seat-configuration + (name "*") + (user-session "ratpoison")))))) + + ;; For debugging. + (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (permit-root-login #t) + (allow-empty-passwords? #t))) + (append minimal-desktop-services + (remove (lambda (service) + (eq? (service-kind service) guix-service-type)) + %base-services)))))) + +(define (run-lightdm-test) + "Run tests in %LIGHTDM-OS." + + (define os (marionette-operating-system + %lightdm-os + #:imported-modules (source-module-closure + '((gnu services herd))))) + + (define vm (virtual-machine os)) + + (define test + (with-imported-modules (source-module-closure + '((gnu build marionette))) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-26) + (srfi srfi-64)) + + (let ((marionette (make-marionette (list #$vm)))) + + (test-runner-current (system-test-runner #$output)) + (test-begin "lightdm") + + (test-assert "service is running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'lightdm)) + marionette)) + + (test-assert "service can be stopped" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (stop-service 'lightdm)) + marionette)) + + (test-assert "service can be restarted" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (restart-service 'lightdm)) + marionette)) + + (test-assert "login screen is displayed" + ;; GNU Ocrad fails to recognize the "Log In" button text, so use + ;; Tesseract. + (wait-for-screen-text marionette + (cut string-contains <> "Log In") + #:ocr #$(file-append tesseract-ocr + "/bin/tesseract"))) + + (test-assert "can connect to TCP port 5900 on IPv4" + (wait-for-tcp-port 5900 marionette)) + + ;; The VNC server fails to listen to IPv6 due to "Error binding to + ;; address [::]:5900: Address already in use" (see: + ;; https://github.com/canonical/lightdm/issues/266). + (test-expect-fail 1) + (test-assert "can connect to TCP port 5900 on IPv6" + (wait-for-tcp-port 5900 marionette + #:address + `(make-socket-address + AF_INET6 + (inet-pton AF_INET6 "::1") + 5900))) + + (test-end))))) + + (gexp->derivation "lightdm-test" test)) + +(define %test-lightdm + (system-test + (name "lightdm") + (description "Basic tests for the LightDM service.") + (value (run-lightdm-test)))) |