services: Add lightdm-service-type.
* gnu/services/lightdm.scm: New service. * tests/services/lightdm.scm: Test it. * doc/guix.texi (X Window): Document it. * gnu/local.mk (GNU_SYSTEM_MODULES): Register it. Co-authored-by: L p R n d n <guix@lprndn.info> Co-authored-by: Ricardo Wurmus <rekado@elephly.net>
This commit is contained in:
Maxim Cournoyer
parent
42fee6d0f1
commit
0ea62e84a7
@ -533,6 +533,7 @@ SCM_TESTS = \
|
|||||||
tests/services.scm \
|
tests/services.scm \
|
||||||
tests/services/file-sharing.scm \
|
tests/services/file-sharing.scm \
|
||||||
tests/services/configuration.scm \
|
tests/services/configuration.scm \
|
||||||
|
tests/services/lightdm.scm \
|
||||||
tests/services/linux.scm \
|
tests/services/linux.scm \
|
||||||
tests/services/telephony.scm \
|
tests/services/telephony.scm \
|
||||||
tests/sets.scm \
|
tests/sets.scm \
|
||||||
|
|||||||
202
doc/guix.texi
202
doc/guix.texi
@ -21278,6 +21278,208 @@ Relogin after logout.
|
|||||||
@end table
|
@end table
|
||||||
@end deftp
|
@end deftp
|
||||||
|
|
||||||
|
@cindex lightdm, graphical login manager
|
||||||
|
@cindex display manager, lightdm
|
||||||
|
@defvr {Scheme Variable} lightdm-service-type
|
||||||
|
This is the type of the service to run the
|
||||||
|
@url{https://github.com/canonical/lightdm,LightDM display manager}. Its
|
||||||
|
value must be a @code{lightdm-configuration} record, which is documented
|
||||||
|
below. Among its distinguishing features are TigerVNC integration for
|
||||||
|
easily remoting your desktop as well as support for the XDMCP protocol,
|
||||||
|
which can be used by remote clients to start a session from the login
|
||||||
|
manager.
|
||||||
|
|
||||||
|
In its most basic form, it can be used simply as:
|
||||||
|
|
||||||
|
@lisp
|
||||||
|
(service lightdm-service-type)
|
||||||
|
@end lisp
|
||||||
|
|
||||||
|
A more elaborate example making use of the VNC capabilities and enabling
|
||||||
|
more features and verbose logs could look like:
|
||||||
|
|
||||||
|
@lisp
|
||||||
|
(service lightdm-service-type
|
||||||
|
(lightdm-configuration
|
||||||
|
(allow-empty-passwords? #t)
|
||||||
|
(xdmcp? #t)
|
||||||
|
(vnc-server? #t)
|
||||||
|
(vnc-server-command
|
||||||
|
(file-append tigervnc-server "/bin/Xvnc"
|
||||||
|
" -SecurityTypes None"))
|
||||||
|
(seats
|
||||||
|
(list (lightdm-seat-configuration
|
||||||
|
(name "*")
|
||||||
|
(user-session "ratpoison"))))))
|
||||||
|
@end lisp
|
||||||
|
@end defvr
|
||||||
|
|
||||||
|
@c The LightDM service documentation can be auto-generated via the
|
||||||
|
@c 'generate-doc' procedure at the bottom of the (gnu services lightdm)
|
||||||
|
@c module.
|
||||||
|
@c %start of fragment
|
||||||
|
@deftp {Data Type} lightdm-configuration
|
||||||
|
Available @code{lightdm-configuration} fields are:
|
||||||
|
|
||||||
|
@table @asis
|
||||||
|
@item @code{lightdm} (default: @code{lightdm}) (type: file-like)
|
||||||
|
The lightdm package to use.
|
||||||
|
|
||||||
|
@item @code{allow-empty-passwords?} (default: @code{#f}) (type: boolean)
|
||||||
|
Whether users not having a password set can login.
|
||||||
|
|
||||||
|
@item @code{debug?} (default: @code{#f}) (type: boolean)
|
||||||
|
Enable verbose output.
|
||||||
|
|
||||||
|
@item @code{xorg-configuration} (type: 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.
|
||||||
|
|
||||||
|
@item @code{greeters} (type: list-of-greeter-configurations)
|
||||||
|
The LightDM greeter configurations specifying the greeters to use.
|
||||||
|
|
||||||
|
@item @code{seats} (type: list-of-seat-configurations)
|
||||||
|
The seat configurations to use. A LightDM seat is akin to a user.
|
||||||
|
|
||||||
|
@item @code{xdmcp?} (default: @code{#f}) (type: boolean)
|
||||||
|
Whether a XDMCP server should listen on port UDP 177.
|
||||||
|
|
||||||
|
@item @code{xdmcp-listen-address} (type: maybe-string)
|
||||||
|
The host or IP address the XDMCP server listens for incoming
|
||||||
|
connections. When unspecified, listen on for any hosts/IP addresses.
|
||||||
|
|
||||||
|
@item @code{vnc-server?} (default: @code{#f}) (type: boolean)
|
||||||
|
Whether a VNC server is started.
|
||||||
|
|
||||||
|
@item @code{vnc-server-command} (type: file-like)
|
||||||
|
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.
|
||||||
|
|
||||||
|
@item @code{vnc-server-listen-address} (type: maybe-string)
|
||||||
|
The host or IP address the VNC server listens for incoming connections.
|
||||||
|
When unspecified, listen for any hosts/IP addresses.
|
||||||
|
|
||||||
|
@item @code{vnc-server-port} (default: @code{5900}) (type: number)
|
||||||
|
The TCP port the VNC server should listen to.
|
||||||
|
|
||||||
|
@item @code{extra-config} (default: @code{()}) (type: list-of-strings)
|
||||||
|
Extra configuration values to append to the LightDM configuration file.
|
||||||
|
|
||||||
|
@end table
|
||||||
|
@end deftp
|
||||||
|
|
||||||
|
|
||||||
|
@c %end of fragment
|
||||||
|
@c %start of fragment
|
||||||
|
|
||||||
|
@deftp {Data Type} lightdm-gtk-greeter-configuration
|
||||||
|
Available @code{lightdm-gtk-greeter-configuration} fields are:
|
||||||
|
|
||||||
|
@table @asis
|
||||||
|
@item @code{lightdm-gtk-greeter} (default: @code{lightdm-gtk-greeter}) (type: file-like)
|
||||||
|
The lightdm-gtk-greeter package to use.
|
||||||
|
|
||||||
|
@item @code{assets} @
|
||||||
|
(default: @code{(adwaita-icon-theme gnome-themes-extrahicolor-icon-theme)}) @
|
||||||
|
(type: list-of-file-likes)
|
||||||
|
The list of packages complementing the greeter, such as package
|
||||||
|
providing icon themes.
|
||||||
|
|
||||||
|
@item @code{theme-name} (default: @code{"Adwaita"}) (type: string)
|
||||||
|
The name of the theme to use.
|
||||||
|
|
||||||
|
@item @code{icon-theme-name} (default: @code{"Adwaita"}) (type: string)
|
||||||
|
The name of the icon theme to use.
|
||||||
|
|
||||||
|
@item @code{cursor-theme-name} (default: @code{"Adwaita"}) (type: string)
|
||||||
|
The name of the cursor theme to use.
|
||||||
|
|
||||||
|
@item @code{cursor-theme-size} (default: @code{16}) (type: number)
|
||||||
|
The size to use for the the cursor theme.
|
||||||
|
|
||||||
|
@item @code{allow-debugging?} (type: maybe-boolean)
|
||||||
|
Set to #t to enable debug log level.
|
||||||
|
|
||||||
|
@item @code{background} (type: file-like)
|
||||||
|
The background image to use.
|
||||||
|
|
||||||
|
@item @code{at-spi-enabled?} (default: @code{#f}) (type: boolean)
|
||||||
|
Enable accessibility support through the Assistive Technology Service
|
||||||
|
Provider Interface (AT-SPI).
|
||||||
|
|
||||||
|
@item @code{a11y-states} @
|
||||||
|
(default: @code{(contrast font keyboard reader)}) (type: list-of-a11y-states)
|
||||||
|
The accessibility features to enable, given as list of symbols.
|
||||||
|
|
||||||
|
@item @code{reader} (type: maybe-file-like)
|
||||||
|
The command to use to launch a screen reader.
|
||||||
|
|
||||||
|
@item @code{extra-config} (default: @code{()}) (type: list-of-strings)
|
||||||
|
Extra configuration values to append to the LightDM GTK Greeter
|
||||||
|
configuration file.
|
||||||
|
|
||||||
|
@end table
|
||||||
|
@end deftp
|
||||||
|
|
||||||
|
@c %end of fragment
|
||||||
|
@c %start of fragment
|
||||||
|
|
||||||
|
@deftp {Data Type} lightdm-seat-configuration
|
||||||
|
Available @code{lightdm-seat-configuration} fields are:
|
||||||
|
|
||||||
|
@table @asis
|
||||||
|
@item @code{name} (type: 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.
|
||||||
|
|
||||||
|
@item @code{user-session} (type: 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.
|
||||||
|
|
||||||
|
@item @code{type} (default: @code{local}) (type: seat-type)
|
||||||
|
The type of the seat, either the @code{local} or @code{xremote} symbol.
|
||||||
|
|
||||||
|
@item @code{autologin-user} (type: maybe-string)
|
||||||
|
The username to automatically log in with by default.
|
||||||
|
|
||||||
|
@item @code{greeter-session} @
|
||||||
|
(default: @code{lightdm-gtk-greeter}) (type: greeter-session)
|
||||||
|
The greeter session to use, specified as a symbol. Currently, only
|
||||||
|
@code{lightdm-gtk-greeter} is supported.
|
||||||
|
|
||||||
|
@item @code{xserver-command} (type: maybe-file-like)
|
||||||
|
The Xorg server command to run.
|
||||||
|
|
||||||
|
@item @code{session-wrapper} (type: file-like)
|
||||||
|
The xinitrc session wrapper to use.
|
||||||
|
|
||||||
|
@item @code{extra-config} (default: @code{()}) (type: list-of-strings)
|
||||||
|
Extra configuration values to append to the seat configuration section.
|
||||||
|
|
||||||
|
@end table
|
||||||
|
@end deftp
|
||||||
|
@c %end of fragment
|
||||||
|
|
||||||
|
|
||||||
@cindex Xorg, configuration
|
@cindex Xorg, configuration
|
||||||
@deftp {Data Type} xorg-configuration
|
@deftp {Data Type} xorg-configuration
|
||||||
|
|||||||
@ -661,6 +661,7 @@ GNU_SYSTEM_MODULES = \
|
|||||||
%D%/services/guix.scm \
|
%D%/services/guix.scm \
|
||||||
%D%/services/hurd.scm \
|
%D%/services/hurd.scm \
|
||||||
%D%/services/kerberos.scm \
|
%D%/services/kerberos.scm \
|
||||||
|
%D%/services/lightdm.scm \
|
||||||
%D%/services/linux.scm \
|
%D%/services/linux.scm \
|
||||||
%D%/services/lirc.scm \
|
%D%/services/lirc.scm \
|
||||||
%D%/services/virtualization.scm \
|
%D%/services/virtualization.scm \
|
||||||
|
|||||||
687
gnu/services/lightdm.scm
Normal file
687
gnu/services/lightdm.scm
Normal file
@ -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))
|
||||||
160
gnu/tests/lightdm.scm
Normal file
160
gnu/tests/lightdm.scm
Normal file
@ -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))))
|
||||||
52
tests/services/lightdm.scm
Normal file
52
tests/services/lightdm.scm
Normal file
@ -0,0 +1,52 @@
|
|||||||
|
;;; 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 (tests services lightdm)
|
||||||
|
#:use-module (guix diagnostics)
|
||||||
|
#:use-module (gnu services lightdm)
|
||||||
|
#:use-module (srfi srfi-64))
|
||||||
|
|
||||||
|
;;; Tests for the (gnu services lightdm) module.
|
||||||
|
|
||||||
|
;;; Access some internals for whitebox testing.
|
||||||
|
(define validate-lightdm-configuration (@@ (gnu services lightdm)
|
||||||
|
validate-lightdm-configuration))
|
||||||
|
|
||||||
|
(test-begin "lightdm-service")
|
||||||
|
|
||||||
|
(test-equal "error on missing greeter"
|
||||||
|
'ok
|
||||||
|
(catch 'quit
|
||||||
|
(lambda ()
|
||||||
|
(validate-lightdm-configuration (lightdm-configuration (greeters '()))))
|
||||||
|
(lambda _
|
||||||
|
'ok)))
|
||||||
|
|
||||||
|
(test-equal "error when a greeter has multiple configurations"
|
||||||
|
'ok
|
||||||
|
(catch 'quit
|
||||||
|
(lambda ()
|
||||||
|
(lightdm-configuration
|
||||||
|
(greeters (list (lightdm-gtk-greeter-configuration
|
||||||
|
(theme-name "boring"))
|
||||||
|
(lightdm-gtk-greeter-configuration
|
||||||
|
(theme-name "blue"))))))
|
||||||
|
(lambda _
|
||||||
|
'ok)))
|
||||||
|
|
||||||
|
(test-end "lightdm-service")
|
||||||
Loading…
Reference in New Issue
Block a user