@@ -533,6 +533,7 @@ SCM_TESTS = \
tests/services.scm \
tests/services/file-sharing.scm \
tests/services/configuration.scm \
+ tests/services/lightdm.scm \
tests/services/linux.scm \
tests/services/telephony.scm \
tests/sets.scm \
@@ -21267,6 +21267,208 @@ Relogin after logout.
@end table
@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
@deftp {Data Type} xorg-configuration
@@ -660,6 +660,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 \
new file mode 100644
@@ -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))
new file mode 100644
@@ -0,0 +1,161 @@
+;;; 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))))
new file mode 100644
@@ -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")