Merge branch 'staging' into core-updates

3 files changed, 1110 insertions, 0 deletions

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/services/security.scm b/gnu/services/security.scm
new file mode 100644
index 0000000000..1e0360c07f
--- /dev/null
+++ b/gnu/services/security.scm
@@ -0,0 +1,415 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 muradm <mail@muradm.net>
+;;;
+;;; 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 security)
+  #:use-module (gnu packages admin)
+  #:use-module (gnu services)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services shepherd)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (guix ui)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (fail2ban-configuration
+            fail2ban-ignore-cache-configuration
+            fail2ban-jail-action-configuration
+            fail2ban-jail-configuration
+            fail2ban-jail-filter-configuration
+            fail2ban-jail-service
+            fail2ban-service-type))
+
+(define-configuration/no-serialization fail2ban-ignore-cache-configuration
+  (key string "Cache key.")
+  (max-count integer "Cache size.")
+  (max-time integer "Cache time."))
+
+(define serialize-fail2ban-ignore-cache-configuration
+  (match-lambda
+    (($ <fail2ban-ignore-cache-configuration> _ key max-count max-time)
+     (format #f "key=\"~a\", max-count=~d, max-time=~d"
+             key max-count max-time))))
+
+(define-maybe/no-serialization string)
+
+(define-configuration/no-serialization fail2ban-jail-filter-configuration
+  (name string "Filter to use.")
+  (mode maybe-string "Mode for filter."))
+
+(define serialize-fail2ban-jail-filter-configuration
+  (match-lambda
+    (($ <fail2ban-jail-filter-configuration> _ name mode)
+     (format #f "~a~@[[mode=~a]~]" name (maybe-value mode)))))
+
+(define (argument? a)
+  (and (pair? a)
+       (string? (car a))
+       (or (string? (cdr a))
+           (list-of-strings? (cdr a)))))
+
+(define list-of-arguments? (list-of argument?))
+
+(define-configuration/no-serialization fail2ban-jail-action-configuration
+  (name string "Action name.")
+  (arguments (list-of-arguments '()) "Action arguments."))
+
+(define list-of-fail2ban-jail-actions?
+  (list-of fail2ban-jail-action-configuration?))
+
+(define (serialize-fail2ban-jail-action-configuration-arguments args)
+  (let* ((multi-value
+          (lambda (v)
+            (format #f "~a" (string-join v ","))))
+         (any-value
+          (lambda (v)
+            (if (list? v) (string-append "\"" (multi-value v) "\"") v)))
+         (key-value
+          (lambda (e)
+            (format #f "~a=~a" (car e) (any-value (cdr e))))))
+    (format #f "~a" (string-join (map key-value args) ","))))
+
+(define serialize-fail2ban-jail-action-configuration
+  (match-lambda
+    (($ <fail2ban-jail-action-configuration> _ name arguments)
+     (format
+      #f "~a~a"
+      name
+      (if (null? arguments) ""
+          (format
+           #f "[~a]"
+           (serialize-fail2ban-jail-action-configuration-arguments
+            arguments)))))))
+
+(define fail2ban-backend->string
+  (match-lambda
+    ('auto "auto")
+    ('pyinotify "pyinotify")
+    ('gamin "gamin")
+    ('polling "polling")
+    ('systemd "systemd")
+    (unknown
+     (leave (G_ "fail2ban: '~a' is not a supported backend~%") unknown))))
+
+(define fail2ban-log-encoding->string
+  (match-lambda
+    ('auto "auto")
+    ('utf-8 "utf-8")
+    ('ascii "ascii")
+    (unknown
+     (leave (G_ "fail2ban: '~a' is not a supported log encoding~%") unknown))))
+
+(define (fail2ban-jail-configuration-serialize-field-name name)
+  (cond ((symbol? name)
+         (fail2ban-jail-configuration-serialize-field-name
+          (symbol->string name)))
+        ((string-suffix? "?" name)
+         (fail2ban-jail-configuration-serialize-field-name
+          (string-drop-right name 1)))
+        ((string-prefix? "ban-time-" name)
+         (fail2ban-jail-configuration-serialize-field-name
+          (string-append "bantime." (substring name 9))))
+        ((string-contains name "-")
+         (fail2ban-jail-configuration-serialize-field-name
+          (string-filter (lambda (c) (equal? c #\-)) name)))
+        (else name)))
+
+(define (fail2ban-jail-configuration-serialize-string field-name value)
+  #~(string-append
+     #$(fail2ban-jail-configuration-serialize-field-name field-name)
+     " = " #$value "\n"))
+
+(define (fail2ban-jail-configuration-serialize-integer field-name value)
+  (fail2ban-jail-configuration-serialize-string
+   field-name (number->string value)))
+
+(define (fail2ban-jail-configuration-serialize-boolean field-name value)
+  (fail2ban-jail-configuration-serialize-string
+   field-name (if value "true" "false")))
+
+(define (fail2ban-jail-configuration-serialize-backend field-name value)
+  (if (maybe-value-set? value)
+      (fail2ban-jail-configuration-serialize-string
+       field-name (fail2ban-backend->string value))
+      ""))
+
+(define (fail2ban-jail-configuration-serialize-fail2ban-ignore-cache-configuration field-name value)
+  (fail2ban-jail-configuration-serialize-string
+   field-name (serialize-fail2ban-ignore-cache-configuration value)))
+
+(define (fail2ban-jail-configuration-serialize-fail2ban-jail-filter-configuration field-name value)
+  (fail2ban-jail-configuration-serialize-string
+   field-name (serialize-fail2ban-jail-filter-configuration value)))
+
+(define (fail2ban-jail-configuration-serialize-log-encoding field-name value)
+  (if (maybe-value-set? value)
+      (fail2ban-jail-configuration-serialize-string
+       field-name (fail2ban-log-encoding->string value))
+      ""))
+
+(define (fail2ban-jail-configuration-serialize-list-of-strings field-name value)
+  (if (null? value)
+      ""
+      (fail2ban-jail-configuration-serialize-string
+       field-name (string-join value " "))))
+
+(define (fail2ban-jail-configuration-serialize-list-of-fail2ban-jail-actions field-name value)
+  (if (null? value)
+      ""
+      (fail2ban-jail-configuration-serialize-string
+       field-name (string-join
+                   (map serialize-fail2ban-jail-action-configuration value) "\n"))))
+
+(define (fail2ban-jail-configuration-serialize-symbol field-name value)
+  (fail2ban-jail-configuration-serialize-string field-name (symbol->string value)))
+
+(define (fail2ban-jail-configuration-serialize-extra-content field-name value)
+  (if (maybe-value-set? value)
+      (string-append "\n" value "\n")
+      ""))
+
+(define-maybe integer (prefix fail2ban-jail-configuration-))
+(define-maybe string (prefix fail2ban-jail-configuration-))
+(define-maybe boolean (prefix fail2ban-jail-configuration-))
+(define-maybe symbol (prefix fail2ban-jail-configuration-))
+(define-maybe fail2ban-ignore-cache-configuration (prefix fail2ban-jail-configuration-))
+(define-maybe fail2ban-jail-filter-configuration (prefix fail2ban-jail-configuration-))
+
+(define-configuration fail2ban-jail-configuration
+  (name
+   string
+   "Required name of this jail configuration.")
+  (enabled?
+   (boolean #t)
+   "Whether this jail is enabled.")
+  (backend
+   maybe-symbol
+   "Backend to use to detect changes in the @code{ogpath}.  The default is
+'auto.  To consult the defaults of the jail configuration, refer to the
+@file{/etc/fail2ban/jail.conf} file of the @code{fail2ban} package."
+fail2ban-jail-configuration-serialize-backend)
+  (max-retry
+   maybe-integer
+   "The number of failures before a host get banned
+(e.g. @code{(max-retry 5)}).")
+  (max-matches
+   maybe-integer
+   "The number of matches stored in ticket (resolvable via
+tag @code{<matches>}) in action.")
+  (find-time
+   maybe-string
+   "The time window during which the maximum retry count must be reached for
+an IP address to be banned.  A host is banned if it has generated
+@code{max-retry} during the last @code{find-time}
+seconds (e.g. @code{(find-time \"10m\")}).  It can be provided in seconds or
+using Fail2Ban's \"time abbreviation format\", as described in @command{man 5
+jail.conf}.")
+  (ban-time
+   maybe-string
+   "The duration, in seconds or time abbreviated format, that a ban should last.
+(e.g. @code{(ban-time \"10m\")}).")
+  (ban-time-increment?
+   maybe-boolean
+   "Whether to consider past bans to compute increases to the default ban time
+of a specific IP address.")
+  (ban-time-factor
+   maybe-string
+   "The coefficient to use to compute an exponentially growing ban time.")
+  (ban-time-formula
+   maybe-string
+   "This is the formula used to calculate the next value of a ban time.")
+  (ban-time-multipliers
+   maybe-string
+   "Used to calculate next value of ban time instead of formula.")
+  (ban-time-max-time
+   maybe-string
+   "The maximum number of seconds a ban should last.")
+  (ban-time-rnd-time
+   maybe-string
+   "The maximum number of seconds a randomized ban time should last.  This can
+be useful to stop ``clever'' botnets calculating the exact time an IP address
+can be unbanned again.")
+  (ban-time-overall-jails?
+   maybe-boolean
+   "When true, it specifies the search of an IP address in the database should
+be made across all jails.  Otherwise, only the current jail of the ban IP
+address is considered.")
+  (ignore-self?
+   maybe-boolean
+   "Never ban the local machine's own IP address.")
+  (ignore-ip
+   (list-of-strings '())
+   "A list of IP addresses, CIDR masks or DNS hosts to ignore.
+@code{fail2ban} will not ban a host which matches an address in this list.")
+  (ignore-cache
+   maybe-fail2ban-ignore-cache-configuration
+   "Provide cache parameters for the ignore failure check.")
+  (filter
+   maybe-fail2ban-jail-filter-configuration
+   "The filter to use by the jail, specified via a
+@code{<fail2ban-jail-filter-configuration>} object.  By default, jails have
+names matching their filter name.")
+  (log-time-zone
+   maybe-string
+   "The default time zone for log lines that do not have one.")
+  (log-encoding
+   maybe-symbol
+   "The encoding of the log files handled by the jail.
+Possible values are: @code{'ascii}, @code{'utf-8} and @code{'auto}."
+fail2ban-jail-configuration-serialize-log-encoding)
+  (log-path
+   (list-of-strings '())
+   "The file names of the log files to be monitored.")
+  (action
+   (list-of-fail2ban-jail-actions '())
+   "A list of @code{<fail2ban-jail-action-configuration>}.")
+  (extra-content
+   maybe-string
+   "Extra content for the jail configuration."
+   fail2ban-jail-configuration-serialize-extra-content)
+  (prefix fail2ban-jail-configuration-))
+
+(define list-of-fail2ban-jail-configurations?
+  (list-of fail2ban-jail-configuration?))
+
+(define (serialize-fail2ban-jail-configuration config)
+  #~(string-append
+     #$(format #f "[~a]\n" (fail2ban-jail-configuration-name config))
+     #$(serialize-configuration
+      config fail2ban-jail-configuration-fields)))
+
+(define-configuration/no-serialization fail2ban-configuration
+  (fail2ban
+   (package fail2ban)
+   "The @code{fail2ban} package to use.  It is used for both binaries and as
+base default configuration that is to be extended with
+@code{<fail2ban-jail-configuration>} objects.")
+  (run-directory
+   (string "/var/run/fail2ban")
+   "The state directory for the @code{fail2ban} daemon.")
+  (jails
+   (list-of-fail2ban-jail-configurations '())
+   "Instances of @code{<fail2ban-jail-configuration>} collected from
+extensions.")
+  (extra-jails
+   (list-of-fail2ban-jail-configurations '())
+   "Instances of @code{<fail2ban-jail-configuration>} explicitly provided.")
+  (extra-content
+   maybe-string
+   "Extra raw content to add to the end of the @file{jail.local} file."))
+
+(define (serialize-fail2ban-configuration config)
+  (let* ((jails (fail2ban-configuration-jails config))
+         (extra-jails (fail2ban-configuration-extra-jails config))
+         (extra-content (fail2ban-configuration-extra-content config)))
+    (interpose
+     (append (map serialize-fail2ban-jail-configuration
+                  (append jails extra-jails))
+             (list (if (maybe-value-set? extra-content)
+                       extra-content
+                       ""))))))
+
+(define (config->fail2ban-etc-directory config)
+  (let* ((fail2ban (fail2ban-configuration-fail2ban config))
+         (jail-local (apply mixed-text-file "jail.local"
+                            (serialize-fail2ban-configuration config))))
+    (directory-union
+     "fail2ban-configuration"
+     (list (computed-file
+            "etc-fail2ban"
+            (with-imported-modules '((guix build utils))
+              #~(begin
+                  (use-modules (guix build utils))
+                  (let ((etc (string-append #$output "/etc")))
+                    (mkdir-p etc)
+                    (symlink #$(file-append fail2ban "/etc/fail2ban")
+                             (string-append etc "/fail2ban"))))))
+           (computed-file
+            "etc-fail2ban-jail.local"
+            (with-imported-modules '((guix build utils))
+              #~(begin
+                  (use-modules (guix build utils))
+                  (define etc/fail2ban (string-append #$output
+                                                      "/etc/fail2ban"))
+                  (mkdir-p etc/fail2ban)
+                  (symlink #$jail-local (string-append etc/fail2ban
+                                                       "/jail.local")))))))))
+
+(define (fail2ban-shepherd-service config)
+  (match-record config <fail2ban-configuration>
+    (fail2ban run-directory)
+    (let* ((fail2ban-server (file-append fail2ban "/bin/fail2ban-server"))
+           (pid-file (in-vicinity run-directory "fail2ban.pid"))
+           (socket-file (in-vicinity run-directory "fail2ban.sock"))
+           (config-dir (file-append (config->fail2ban-etc-directory config)
+                                    "/etc/fail2ban"))
+           (fail2ban-action (lambda args
+                              #~(lambda _
+                                  (invoke #$fail2ban-server
+                                          "-c" #$config-dir
+                                          "-p" #$pid-file
+                                          "-s" #$socket-file
+                                          "-b"
+                                          #$@args)))))
+
+      ;; TODO: Add 'reload' action.
+      (list (shepherd-service
+             (provision '(fail2ban))
+             (documentation "Run the fail2ban daemon.")
+             (requirement '(user-processes))
+             (modules `((ice-9 match)
+                        ,@%default-modules))
+             (start (fail2ban-action "start"))
+             (stop (fail2ban-action "stop")))))))
+
+(define fail2ban-service-type
+  (service-type (name 'fail2ban)
+                (extensions
+                 (list (service-extension shepherd-root-service-type
+                                          fail2ban-shepherd-service)))
+                (compose concatenate)
+                (extend (lambda (config jails)
+                          (fail2ban-configuration
+                           (inherit config)
+                           (jails (append (fail2ban-configuration-jails config)
+                                          jails)))))
+                (default-value (fail2ban-configuration))
+                (description "Run the fail2ban server.")))
+
+(define (fail2ban-jail-service svc-type jail)
+  "Convenience procedure to add a fail2ban service extension to SVC-TYPE, a
+<service-type> object.  The fail2ban extension is specified by JAIL, a
+<fail2ban-jail-configuration> object."
+  (service-type
+   (inherit svc-type)
+   (extensions
+    (append (service-type-extensions svc-type)
+            (list (service-extension fail2ban-service-type
+                                     (lambda _ (list jail))))))))
+
+
+;;;
+;;; Documentation generation.
+;;;
+(define (generate-doc)
+  (configuration->documentation 'fail2ban-configuration)
+  (configuration->documentation 'fail2ban-ignore-cache-configuration)
+  (configuration->documentation 'fail2ban-jail-action-configuration)
+  (configuration->documentation 'fail2ban-jail-configuration)
+  (configuration->documentation 'fail2ban-jail-filter-configuration))
diff --git a/gnu/services/version-control.scm b/gnu/services/version-control.scm
index defbd65c36..17a5f9c867 100644
--- a/gnu/services/version-control.scm
+++ b/gnu/services/version-control.scm
@@ -331,6 +331,14 @@ access to exported repositories under @file{/srv/git}."
                                (strip-store-file-name admin-pubkey))))
                 (rc-file #$(string-append home "/.gitolite.rc")))
 
+           ;; activate-users+groups in (gnu build activation) sets the
+           ;; permission flags of home directories to #o700 and mentions that
+           ;; services needing looser permissions should chmod it during
+           ;; service activation.  We also want the git group to be able to
+           ;; read from the gitolite home directory, so a chmod'ing we will
+           ;; go!
+           (chmod #$home #o750)
+
            (simple-format #t "guix: gitolite: installing ~A\n" #$rc-file)
            (copy-file #$rc-file rc-file)
            ;; ensure gitolite's user can read the configuration