summaryrefslogtreecommitdiff
path: root/gnu/services/desktop.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services/desktop.scm')
-rw-r--r--gnu/services/desktop.scm258
1 files changed, 156 insertions, 102 deletions
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index 69edc6d9bb..694a8eda7e 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -27,13 +27,15 @@
#:use-module (gnu services xorg)
#:use-module (gnu services networking)
#:use-module (gnu system shadow)
- #:use-module (gnu system linux) ; unix-pam-service
+ #:use-module (gnu system pam)
#:use-module (gnu packages glib)
#:use-module (gnu packages admin)
#:use-module (gnu packages freedesktop)
#:use-module (gnu packages gnome)
#:use-module (gnu packages avahi)
#:use-module (gnu packages polkit)
+ #:use-module (gnu packages xdisorg)
+ #:use-module (gnu packages suckless)
#:use-module (guix records)
#:use-module (guix packages)
#:use-module (guix store)
@@ -41,6 +43,7 @@
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (upower-service
+ udisks-service
colord-service
geoclue-application
%standard-geoclue-applications
@@ -224,65 +227,6 @@ levels, with the given configuration settings. It implements the
;;;
-;;; Colord D-Bus service.
-;;;
-
-(define %colord-activation
- #~(begin
- (use-modules (guix build utils))
- (mkdir-p "/var/lib/colord")
- (let ((user (getpwnam "colord")))
- (chown "/var/lib/colord"
- (passwd:uid user) (passwd:gid user)))))
-
-(define %colord-accounts
- (list (user-group (name "colord") (system? #t))
- (user-account
- (name "colord")
- (group "colord")
- (system? #t)
- (comment "colord daemon user")
- (home-directory "/var/empty")
- (shell #~(string-append #$shadow "/sbin/nologin")))))
-
-(define (colord-dmd-service colord)
- "Return a dmd service for COLORD."
- ;; TODO: Remove when D-Bus activation works.
- (list (dmd-service
- (documentation "Run the colord color management service.")
- (provision '(colord-daemon))
- (requirement '(dbus-system udev))
- (start #~(make-forkexec-constructor
- (list (string-append #$colord "/libexec/colord"))))
- (stop #~(make-kill-destructor)))))
-
-(define colord-service-type
- (service-type (name 'colord)
- (extensions
- (list (service-extension account-service-type
- (const %colord-accounts))
- (service-extension activation-service-type
- (const %colord-activation))
- (service-extension dmd-root-service-type
- colord-dmd-service)
-
- ;; Colord is a D-Bus service that dbus-daemon can
- ;; activate.
- (service-extension dbus-root-service-type list)
-
- ;; Colord provides "color device" rules for udev.
- (service-extension udev-service-type list)))))
-
-(define* (colord-service #:key (colord colord))
- "Return a service that runs @command{colord}, a system service with a D-Bus
-interface to manage the color profiles of input and output devices such as
-screens and scanners. It is notably used by the GNOME Color Manager graphical
-tool. See @uref{http://www.freedesktop.org/software/colord/, the colord web
-site} for more information."
- (service colord-service-type colord))
-
-
-;;;
;;; GeoClue D-Bus service.
;;;
@@ -343,23 +287,6 @@ users are allowed."
"GEOCLUE_CONFIG_FILE"
(geoclue-configuration-file config))))
-(define (geoclue-dmd-service config)
- "Return a GeoClue dmd service for CONFIG."
- ;; TODO: Remove when D-Bus activation works.
- (let ((geoclue (geoclue-configuration-geoclue config))
- (config (geoclue-configuration-file config)))
- (list (dmd-service
- (documentation "Run the GeoClue location service.")
- (provision '(geoclue-daemon))
- (requirement '(dbus-system))
-
- (start #~(make-forkexec-constructor
- (list (string-append #$geoclue "/libexec/geoclue"))
- #:user "geoclue"
- #:environment-variables
- (list (string-append "GEOCLUE_CONFIG_FILE=" #$config))))
- (stop #~(make-kill-destructor))))))
-
(define %geoclue-accounts
(list (user-group (name "geoclue") (system? #t))
(user-account
@@ -375,8 +302,6 @@ users are allowed."
(extensions
(list (service-extension dbus-root-service-type
geoclue-dbus-service)
- (service-extension dmd-root-service-type
- geoclue-dmd-service)
(service-extension account-service-type
(const %geoclue-accounts))))))
@@ -413,6 +338,14 @@ site} for more information."
;;; Polkit privilege management service.
;;;
+(define-record-type* <polkit-configuration>
+ polkit-configuration make-polkit-configuration
+ polkit-configuration?
+ (polkit polkit-configuration-polkit ;<package>
+ (default polkit))
+ (actions polkit-configuration-actions ;list of <package>
+ (default '())))
+
(define %polkit-accounts
(list (user-group (name "polkitd") (system? #t))
(user-account
@@ -424,23 +357,34 @@ site} for more information."
(shell "/run/current-system/profile/sbin/nologin"))))
(define %polkit-pam-services
- (list (unix-pam-service "polkitd")))
+ (list (unix-pam-service "polkit-1")))
-(define (polkit-dmd-service polkit)
- "Return the <dmd-service> for POLKIT."
- ;; TODO: Remove when D-Bus activation works.
- (list (dmd-service
- (documentation "Run the polkit privilege management service.")
- (provision '(polkit-daemon))
- (requirement '(dbus-system))
+(define (polkit-directory packages)
+ "Return a directory containing an @file{actions} and possibly a
+@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
+ (computed-file "etc-polkit-1"
+ #~(begin
+ (use-modules (guix build union) (srfi srfi-26))
+
+ (union-build #$output
+ (map (cut string-append <>
+ "/share/polkit-1")
+ (list #$@packages))))
+ #:modules '((guix build union))))
- (start #~(make-forkexec-constructor
- (list (string-append #$polkit "/lib/polkit-1/polkitd"))))
- (stop #~(make-kill-destructor)))))
+(define polkit-etc-files
+ (match-lambda
+ (($ <polkit-configuration> polkit packages)
+ `(("polkit-1" ,(polkit-directory packages))))))
+
+(define polkit-setuid-programs
+ (match-lambda
+ (($ <polkit-configuration> polkit)
+ (list #~(string-append #$polkit
+ "/lib/polkit-1/polkit-agent-helper-1")
+ #~(string-append #$polkit "/bin/pkexec")))))
(define polkit-service-type
- ;; TODO: Make it extensible so it can collect policy files from other
- ;; services.
(service-type (name 'polkit)
(extensions
(list (service-extension account-service-type
@@ -448,17 +392,118 @@ site} for more information."
(service-extension pam-root-service-type
(const %polkit-pam-services))
(service-extension dbus-root-service-type
- list)
- (service-extension dmd-root-service-type
- polkit-dmd-service)))))
+ (compose
+ list
+ polkit-configuration-polkit))
+ (service-extension etc-service-type
+ polkit-etc-files)
+ (service-extension setuid-program-service-type
+ polkit-setuid-programs)))
+
+ ;; Extensions are lists of packages that provide polkit rules
+ ;; or actions under share/polkit-1/{actions,rules.d}.
+ (compose concatenate)
+ (extend (lambda (config actions)
+ (polkit-configuration
+ (inherit config)
+ (actions
+ (append (polkit-configuration-actions config)
+ actions)))))))
(define* (polkit-service #:key (polkit polkit))
- "Return a service that runs the @command{polkit} privilege management
-service. By querying the @command{polkit} service, a privileged system
-component can know when it should grant additional capabilities to ordinary
-users. For example, an ordinary user can be granted the capability to suspend
-the system if the user is logged in locally."
- (service polkit-service-type polkit))
+ "Return a service that runs the
+@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
+management service}, which allows system administrators to grant access to
+privileged operations in a structured way. By querying the Polkit service, a
+privileged system component can know when it should grant additional
+capabilities to ordinary users. For example, an ordinary user can be granted
+the capability to suspend the system if the user is logged in locally."
+ (service polkit-service-type
+ (polkit-configuration (polkit polkit))))
+
+
+;;;
+;;; Colord D-Bus service.
+;;;
+
+(define %colord-activation
+ #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p "/var/lib/colord")
+ (let ((user (getpwnam "colord")))
+ (chown "/var/lib/colord"
+ (passwd:uid user) (passwd:gid user)))))
+
+(define %colord-accounts
+ (list (user-group (name "colord") (system? #t))
+ (user-account
+ (name "colord")
+ (group "colord")
+ (system? #t)
+ (comment "colord daemon user")
+ (home-directory "/var/empty")
+ (shell #~(string-append #$shadow "/sbin/nologin")))))
+
+(define colord-service-type
+ (service-type (name 'colord)
+ (extensions
+ (list (service-extension account-service-type
+ (const %colord-accounts))
+ (service-extension activation-service-type
+ (const %colord-activation))
+
+ ;; Colord is a D-Bus service that dbus-daemon can
+ ;; activate.
+ (service-extension dbus-root-service-type list)
+
+ ;; Colord provides "color device" rules for udev.
+ (service-extension udev-service-type list)
+
+ ;; It provides polkit "actions".
+ (service-extension polkit-service-type list)))))
+
+(define* (colord-service #:key (colord colord))
+ "Return a service that runs @command{colord}, a system service with a D-Bus
+interface to manage the color profiles of input and output devices such as
+screens and scanners. It is notably used by the GNOME Color Manager graphical
+tool. See @uref{http://www.freedesktop.org/software/colord/, the colord web
+site} for more information."
+ (service colord-service-type colord))
+
+
+;;;
+;;; UDisks.
+;;;
+
+(define-record-type* <udisks-configuration>
+ udisks-configuration make-udisks-configuration
+ udisks-configuration?
+ (udisks udisks-configuration-udisks
+ (default udisks)))
+
+(define udisks-service-type
+ (let ((udisks-package (lambda (config)
+ (list (udisks-configuration-udisks config)))))
+ (service-type (name 'udisks)
+ (extensions
+ (list (service-extension polkit-service-type
+ udisks-package)
+ (service-extension dbus-root-service-type
+ udisks-package)
+ (service-extension udev-service-type
+ udisks-package)
+
+ ;; Profile 'udisksctl' & co. in the system profile.
+ (service-extension profile-service-type
+ udisks-package))))))
+
+(define* (udisks-service #:key (udisks udisks))
+ "Return a service for @uref{http://udisks.freedesktop.org/docs/latest/,
+UDisks}, a @dfn{disk management} daemon that provides user interfaces with
+notifications and ways to mount/unmount disks. Programs that talk to UDisks
+include the @command{udisksctl} command, part of UDisks, and GNOME Disks."
+ (service udisks-service-type
+ (udisks-configuration (udisks udisks))))
;;;
@@ -601,6 +646,8 @@ the system if the user is logged in locally."
(define (elogind-dmd-service config)
"Return a dmd service for elogind, using @var{config}."
+ ;; TODO: We could probably rely on service activation but the '.service'
+ ;; file currently contains an erroneous 'Exec' line.
(let ((config-file (elogind-configuration-file config))
(elogind (elogind-package config)))
(list (dmd-service
@@ -623,7 +670,9 @@ the system if the user is logged in locally."
(compose list elogind-package))
(service-extension udev-service-type
(compose list elogind-package))
- ;; TODO: Extend polkit(?) and PAM.
+ (service-extension polkit-service-type
+ (compose list elogind-package))
+ ;; TODO: Extend PAM with pam_elogind.so.
))))
(define* (elogind-service #:key (config (elogind-configuration)))
@@ -643,9 +692,14 @@ when they log out."
;; List of services typically useful for a "desktop" use case.
(cons* (slim-service)
+ ;; Screen lockers are a pretty useful thing and these are small.
+ (screen-locker-service slock)
+ (screen-locker-service xlockmore "xlock")
+
;; The D-Bus clique.
(avahi-service)
(wicd-service)
+ (udisks-service)
(upower-service)
(colord-service)
(geoclue-service)
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-09 15:15:56 +0000