;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
(define-module (gnu services desktop)
#:use-module (gnu services)
- #:use-module (gnu services dmd)
+ #:use-module (gnu services shepherd)
#:use-module (gnu services base)
#:use-module (gnu services dbus)
#:use-module (gnu services avahi)
#: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 xfce)
#: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)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (upower-service
+ udisks-service
colord-service
geoclue-application
%standard-geoclue-applications
polkit-service
elogind-configuration
elogind-service
+ gnome-desktop-service
+ xfce-desktop-service
%desktop-services))
;;; Commentary:
(define (bool value)
(if value "true\n" "false\n"))
+(define (package-direct-input-selector input)
+ (lambda (package)
+ (match (assoc-ref (package-direct-inputs package) input)
+ ((package . _) package))))
+
(define (wrapped-dbus-service service program variable value)
"Return a wrapper for @var{service}, a package containing a D-Bus service,
"UPOWER_CONF_FILE_NAME"
(upower-configuration-file config))))
-(define (upower-dmd-service config)
- "Return a dmd service for UPower with CONFIG."
+(define (upower-shepherd-service config)
+ "Return a shepherd service for UPower with CONFIG."
(let ((upower (upower-configuration-upower config))
(config (upower-configuration-file config)))
- (list (dmd-service
+ (list (shepherd-service
(documentation "Run the UPower power and battery monitor.")
(provision '(upower-daemon))
(requirement '(dbus-system udev))
(stop #~(make-kill-destructor))))))
(define upower-service-type
- (service-type (name 'upower)
- (extensions
- (list (service-extension dbus-root-service-type
- upower-dbus-service)
- (service-extension dmd-root-service-type
- upower-dmd-service)
- (service-extension activation-service-type
- (const %upower-activation))
- (service-extension udev-service-type
- (compose
- list
- upower-configuration-upower))))))
+ (let ((upower-package (compose list upower-configuration-upower)))
+ (service-type (name 'upower)
+ (extensions
+ (list (service-extension dbus-root-service-type
+ upower-dbus-service)
+ (service-extension shepherd-root-service-type
+ upower-shepherd-service)
+ (service-extension activation-service-type
+ (const %upower-activation))
+ (service-extension udev-service-type
+ upower-package)
+
+ ;; Make the 'upower' command visible.
+ (service-extension profile-service-type
+ upower-package))))))
(define* (upower-service #:key (upower upower)
(watts-up-pro? #f)
(service upower-service-type config)))
\f
-;;;
-;;; 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))
-
-\f
;;;
;;; GeoClue D-Bus service.
;;;
"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
(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))))))
;;; 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
(shell "/run/current-system/profile/sbin/nologin"))))
(define %polkit-pam-services
- (list (unix-pam-service "polkitd")))
+ (list (unix-pam-service "polkit-1")))
+
+(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))
-(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))
+ (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 (cons polkit 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
(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))))
+
+\f
+;;;
+;;; 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))
+
+\f
+;;;
+;;; 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))))
\f
;;;
("HybridSleepState" (sleep-list elogind-hybrid-sleep-state))
("HybridSleepMode" (sleep-list elogind-hybrid-sleep-mode))))
-(define (elogind-dmd-service config)
- "Return a dmd service for elogind, using @var{config}."
- (let ((config-file (elogind-configuration-file config))
- (elogind (elogind-package config)))
- (list (dmd-service
- (documentation "Run the elogind login and seat management service.")
- (provision '(elogind))
- (requirement '(dbus-system))
-
- (start #~(make-forkexec-constructor
- (list (string-append #$elogind "/libexec/elogind/elogind"))
- #:environment-variables
- (list (string-append "ELOGIND_CONF_FILE=" #$config-file))))
- (stop #~(make-kill-destructor))))))
+(define (elogind-dbus-service config)
+ (list (wrapped-dbus-service (elogind-package config)
+ "libexec/elogind/elogind"
+ "ELOGIND_CONF_FILE"
+ (elogind-configuration-file config))))
+
+(define (pam-extension-procedure config)
+ "Return an extension for PAM-ROOT-SERVICE-TYPE that ensures that all the PAM
+services use 'pam_elogind.so', a module that allows elogind to keep track of
+logged-in users (run 'loginctl' to see elogind's world view of users and
+seats.)"
+ (define pam-elogind
+ (pam-entry
+ (control "required")
+ (module #~(string-append #$(elogind-package config)
+ "/lib/security/pam_elogind.so"))))
+
+ (list (lambda (pam)
+ (pam-service
+ (inherit pam)
+ (session (cons pam-elogind (pam-service-session pam)))))))
(define elogind-service-type
(service-type (name 'elogind)
(extensions
- (list (service-extension dmd-root-service-type
- elogind-dmd-service)
- (service-extension dbus-root-service-type
- (compose list elogind-package))
+ (list (service-extension dbus-root-service-type
+ elogind-dbus-service)
(service-extension udev-service-type
(compose list elogind-package))
- ;; TODO: Extend polkit(?) and PAM.
- ))))
+ (service-extension polkit-service-type
+ (compose list elogind-package))
+
+ ;; Provide the 'loginctl' command.
+ (service-extension profile-service-type
+ (compose list elogind-package))
+
+ ;; Extend PAM with pam_elogind.so.
+ (service-extension pam-root-service-type
+ pam-extension-procedure)))))
(define* (elogind-service #:key (config (elogind-configuration)))
"Return a service that runs the @command{elogind} login and seat management
(service elogind-service-type config))
\f
+;;;
+;;; GNOME desktop service.
+;;;
+
+(define-record-type* <gnome-desktop-configuration> gnome-desktop-configuration
+ make-gnome-desktop-configuration
+ gnome-desktop-configuration
+ (gnome-package gnome-package (default gnome)))
+
+(define gnome-desktop-service-type
+ (service-type
+ (name 'gnome-desktop)
+ (extensions
+ (list (service-extension polkit-service-type
+ (compose list
+ (package-direct-input-selector
+ "gnome-settings-daemon")
+ gnome-package))
+ (service-extension profile-service-type
+ (compose list
+ gnome-package))))))
+
+(define* (gnome-desktop-service #:key (config (gnome-desktop-configuration)))
+ "Return a service that adds the @code{gnome} package to the system profile,
+and extends polkit with the actions from @code{gnome-settings-daemon}."
+ (service gnome-desktop-service-type config))
+
+\f
+;;;
+;;; XFCE desktop service.
+;;;
+
+(define-record-type* <xfce-desktop-configuration> xfce-desktop-configuration
+ make-xfce-desktop-configuration
+ xfce-desktop-configuration
+ (xfce xfce-package (default xfce)))
+
+(define xfce-desktop-service-type
+ (service-type
+ (name 'xfce-desktop)
+ (extensions
+ (list (service-extension polkit-service-type
+ (compose list
+ (package-direct-input-selector
+ "thunar")
+ xfce-package))
+ (service-extension profile-service-type
+ (compose list
+ xfce-package))))))
+
+(define* (xfce-desktop-service #:key (config (xfce-desktop-configuration)))
+ "Return a service that adds the @code{xfce} package to the system profile,
+and extends polkit with the abilit for @code{thunar} to manipulate the file
+system as root from within a user session, after the user has authenticated
+with the administrator's password."
+ (service xfce-desktop-service-type config))
+
+\f
;;;
;;; The default set of desktop services.
;;;
;; 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)
HCoop / jackhill / guix / guix.git / blobdiff