[jackhill/guix/guix.git] / gnu / services / desktop.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Andy Wingo <wingo@igalia.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 desktop)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services avahi)
  #:use-module (gnu services xorg)
  #:use-module (gnu services networking)
  #:use-module (gnu system shadow)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages gnome)
  #:use-module (gnu packages avahi)
  #:use-module (gnu packages wicd)
  #:use-module (guix monads)
  #:use-module (guix store)
  #:use-module (guix gexp)
  #:use-module (ice-9 match)
  #:export (dbus-service
            upower-service
            colord-service
            %desktop-services))

;;; Commentary:
;;;
;;; This module contains service definitions for a "desktop" environment.
;;;
;;; Code:

\f
;;;
;;; D-Bus.
;;;

(define (dbus-configuration-directory dbus services)
  "Return a configuration directory for @var{dbus} that includes the
@code{etc/dbus-1/system.d} directories of each package listed in
@var{services}."
  (define build
    #~(begin
        (use-modules (sxml simple)
                     (srfi srfi-1))

        (define (services->sxml services)
          ;; Return the SXML 'includedir' clauses for DIRS.
          `(busconfig
            ,@(append-map (lambda (dir)
                            `((includedir
                               ,(string-append dir "/etc/dbus-1/system.d"))
                              (servicedir         ;for '.service' files
                               ,(string-append dir "/share/dbus-1/services"))))
                          services)))

        (mkdir #$output)
        (copy-file (string-append #$dbus "/etc/dbus-1/system.conf")
                   (string-append #$output "/system.conf"))

        ;; The default 'system.conf' has an <includedir> clause for
        ;; 'system.d', so create it.
        (mkdir (string-append #$output "/system.d"))

        ;; 'system-local.conf' is automatically included by the default
        ;; 'system.conf', so this is where we stuff our own things.
        (call-with-output-file (string-append #$output "/system-local.conf")
          (lambda (port)
            (sxml->xml (services->sxml (list #$@services))
                       port)))))

  (gexp->derivation "dbus-configuration" build))

(define* (dbus-service services #:key (dbus dbus))
  "Return a service that runs the \"system bus\", using @var{dbus}, with
support for @var{services}.

@uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
facility.  Its system bus is used to allow system services to communicate and
be notified of system-wide events.

@var{services} must be a list of packages that provide an
@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
and policy files.  For example, to allow avahi-daemon to use the system bus,
@var{services} must be equal to @code{(list avahi)}."
  (mlet %store-monad ((conf (dbus-configuration-directory dbus services)))
    (return
     (service
      (documentation "Run the D-Bus system daemon.")
      (provision '(dbus-system))
      (requirement '(user-processes))
      (start #~(make-forkexec-constructor
                (list (string-append #$dbus "/bin/dbus-daemon")
                      "--nofork"
                      (string-append "--config-file=" #$conf "/system.conf"))))
      (stop #~(make-kill-destructor))
      (user-groups (list (user-group
                          (name "messagebus")
                          (system? #t))))
      (user-accounts (list (user-account
                            (name "messagebus")
                            (group "messagebus")
                            (system? #t)
                            (comment "D-Bus system bus user")
                            (home-directory "/var/run/dbus")
                            (shell
                             #~(string-append #$shadow "/sbin/nologin")))))
      (activate #~(begin
                    (use-modules (guix build utils))

                    (mkdir-p "/var/run/dbus")

                    (let ((user (getpwnam "messagebus")))
                      (chown "/var/run/dbus"
                             (passwd:uid user) (passwd:gid user)))

                    (unless (file-exists? "/etc/machine-id")
                      (format #t "creating /etc/machine-id...~%")
                      (let ((prog (string-append #$dbus "/bin/dbus-uuidgen")))
                        ;; XXX: We can't use 'system' because the initrd's
                        ;; guile system(3) only works when 'sh' is in $PATH.
                        (let ((pid (primitive-fork)))
                          (if (zero? pid)
                              (call-with-output-file "/etc/machine-id"
                                (lambda (port)
                                  (close-fdes 1)
                                  (dup2 (port->fdes port) 1)
                                  (execl prog)))
                              (waitpid pid)))))))))))

\f
;;;
;;; Upower D-Bus service.
;;;

(define* (upower-configuration-file #:key watts-up-pro? poll-batteries?
                                    ignore-lid? use-percentage-for-policy?
                                    percentage-low percentage-critical
                                    percentage-action time-low
                                    time-critical time-action
                                    critical-power-action)
  "Return an upower-daemon configuration file."
  (define (bool value)
    (if value "true\n" "false\n"))

  (text-file "UPower.conf"
             (string-append
              "[UPower]\n"
              "EnableWattsUpPro=" (bool watts-up-pro?)
              "NoPollBatteries=" (bool (not poll-batteries?))
              "IgnoreLid=" (bool ignore-lid?)
              "UsePercentageForPolicy=" (bool use-percentage-for-policy?)
              "PercentageLow=" (number->string percentage-low) "\n"
              "PercentageCritical=" (number->string percentage-critical) "\n"
              "PercentageAction=" (number->string percentage-action) "\n"
              "TimeLow=" (number->string time-low) "\n"
              "TimeCritical=" (number->string time-critical) "\n"
              "TimeAction=" (number->string time-action) "\n"
              "CriticalPowerAction=" (match critical-power-action
                                       ('hybrid-sleep "HybridSleep")
                                       ('hibernate "Hibernate")
                                       ('power-off "PowerOff"))
              "\n")))

(define* (upower-service #:key (upower upower)
                         (watts-up-pro? #f)
                         (poll-batteries? #t)
                         (ignore-lid? #f)
                         (use-percentage-for-policy? #f)
                         (percentage-low 10)
                         (percentage-critical 3)
                         (percentage-action 2)
                         (time-low 1200)
                         (time-critical 300)
                         (time-action 120)
                         (critical-power-action 'hybrid-sleep))
  "Return a service that runs @uref{http://upower.freedesktop.org/,
@command{upowerd}}, a system-wide monitor for power consumption and battery
levels, with the given configuration settings.  It implements the
@code{org.freedesktop.UPower} D-Bus interface, and is notably used by GNOME."
  (mlet %store-monad ((config (upower-configuration-file
                               #:watts-up-pro? watts-up-pro?
                               #:poll-batteries? poll-batteries?
                               #:ignore-lid? ignore-lid?
                               #:use-percentage-for-policy? use-percentage-for-policy?
                               #:percentage-low percentage-low
                               #:percentage-critical percentage-critical
                               #:percentage-action percentage-action
                               #:time-low time-low
                               #:time-critical time-critical
                               #:time-action time-action
                               #:critical-power-action critical-power-action)))
    (return
     (service
      (documentation "Run the UPower power and battery monitor.")
      (provision '(upower-daemon))
      (requirement '(dbus-system udev))

      (start #~(make-forkexec-constructor
                (list (string-append #$upower "/libexec/upowerd"))
                #:environment-variables
                (list (string-append "UPOWER_CONF_FILE_NAME=" #$config))))
      (stop #~(make-kill-destructor))
      (activate #~(begin
                    (use-modules (guix build utils))
                    (mkdir-p "/var/lib/upower")
                    (let ((user (getpwnam "upower")))
                      (chown "/var/lib/upower"
                             (passwd:uid user) (passwd:gid user)))))

      (user-groups (list (user-group
                          (name "upower")
                          (system? #t))))
      (user-accounts (list (user-account
                            (name "upower")
                            (group "upower")
                            (system? #t)
                            (comment "UPower daemon user")
                            (home-directory "/var/empty")
                            (shell
                             #~(string-append #$shadow "/sbin/nologin")))))))))

\f
;;;
;;; Colord D-Bus service.
;;;

(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."
  (with-monad %store-monad
    (return
     (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))
      (activate #~(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)))))

      (user-groups (list (user-group
                          (name "colord")
                          (system? #t))))
      (user-accounts (list (user-account
                            (name "colord")
                            (group "colord")
                            (system? #t)
                            (comment "colord daemon user")
                            (home-directory "/var/empty")
                            (shell
                             #~(string-append #$shadow "/sbin/nologin")))))))))

(define %desktop-services
  ;; List of services typically useful for a "desktop" use case.
  (cons* (slim-service)

         (avahi-service)
         (wicd-service)
         (upower-service)
         (colord-service)
         (dbus-service (list avahi wicd upower colord))

         (ntp-service)

         (map (lambda (mservice)
                ;; Provide an nscd ready to use nss-mdns.
                (mlet %store-monad ((service mservice))
                  (if (memq 'nscd (service-provision service))
                      (nscd-service (nscd-configuration)
                                    #:name-services (list nss-mdns))
                      mservice)))
              %base-services)))

;;; desktop.scm ends here
Commit	Line	Data
fe1a39d3 LC	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
	3	;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
	4	;;;
	5	;;; This file is part of GNU Guix.
	6	;;;
	7	;;; GNU Guix is free software; you can redistribute it and/or modify it
	8	;;; under the terms of the GNU General Public License as published by
	9	;;; the Free Software Foundation; either version 3 of the License, or (at
	10	;;; your option) any later version.
	11	;;;
	12	;;; GNU Guix is distributed in the hope that it will be useful, but
	13	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	14	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	;;; GNU General Public License for more details.
	16	;;;
	17	;;; You should have received a copy of the GNU General Public License
	18	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	19
	20	(define-module (gnu services desktop)
	21	#:use-module (gnu services)
4467be21 LC	22	#:use-module (gnu services base)
	23	#:use-module (gnu services avahi)
	24	#:use-module (gnu services xorg)
	25	#:use-module (gnu services networking)
fe1a39d3 LC	26	#:use-module (gnu system shadow)
	27	#:use-module (gnu packages glib)
	28	#:use-module (gnu packages admin)
	29	#:use-module (gnu packages gnome)
4467be21 LC	30	#:use-module (gnu packages avahi)
4467be21 LC	31	#:use-module (gnu packages wicd)
fe1a39d3 LC	32	#:use-module (guix monads)
	33	#:use-module (guix store)
	34	#:use-module (guix gexp)
	35	#:use-module (ice-9 match)
	36	#:export (dbus-service
	37	upower-service
4467be21 LC	38	colord-service
4467be21 LC	39	%desktop-services))
fe1a39d3 LC	40
	41	;;; Commentary:
	42	;;;
	43	;;; This module contains service definitions for a "desktop" environment.
	44	;;;
	45	;;; Code:
	46
	47	\f
	48	;;;
	49	;;; D-Bus.
	50	;;;
	51
	52	(define (dbus-configuration-directory dbus services)
	53	"Return a configuration directory for @var{dbus} that includes the
	54	@code{etc/dbus-1/system.d} directories of each package listed in
	55	@var{services}."
	56	(define build
	57	#~(begin
	58	(use-modules (sxml simple)
	59	(srfi srfi-1))
	60
	61	(define (services->sxml services)
	62	;; Return the SXML 'includedir' clauses for DIRS.
	63	`(busconfig
	64	,@(append-map (lambda (dir)
	65	`((includedir
	66	,(string-append dir "/etc/dbus-1/system.d"))
	67	(servicedir ;for '.service' files
	68	,(string-append dir "/share/dbus-1/services"))))
	69	services)))
	70
	71	(mkdir #$output)
	72	(copy-file (string-append #$dbus "/etc/dbus-1/system.conf")
	73	(string-append #$output "/system.conf"))
	74
	75	;; The default 'system.conf' has an <includedir> clause for
	76	;; 'system.d', so create it.
	77	(mkdir (string-append #$output "/system.d"))
	78
	79	;; 'system-local.conf' is automatically included by the default
	80	;; 'system.conf', so this is where we stuff our own things.
	81	(call-with-output-file (string-append #$output "/system-local.conf")
	82	(lambda (port)
	83	(sxml->xml (services->sxml (list #$@services))
	84	port)))))
	85
	86	(gexp->derivation "dbus-configuration" build))
	87
	88	(define* (dbus-service services #:key (dbus dbus))
	89	"Return a service that runs the \"system bus\", using @var{dbus}, with
	90	support for @var{services}.
	91
	92	@uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
	93	facility. Its system bus is used to allow system services to communicate and
	94	be notified of system-wide events.
	95
	96	@var{services} must be a list of packages that provide an
	97	@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
	98	and policy files. For example, to allow avahi-daemon to use the system bus,
	99	@var{services} must be equal to @code{(list avahi)}."
	100	(mlet %store-monad ((conf (dbus-configuration-directory dbus services)))
	101	(return
	102	(service
	103	(documentation "Run the D-Bus system daemon.")
104	(provision '(dbus-system))
105	(requirement '(user-processes))
106	(start #~(make-forkexec-constructor
107	(list (string-append #$dbus "/bin/dbus-daemon")
108	"--nofork"
109	(string-append "--config-file=" #$conf "/system.conf"))))
110	(stop #~(make-kill-destructor))
111	(user-groups (list (user-group
112	(name "messagebus")
113	(system? #t))))
114	(user-accounts (list (user-account
115	(name "messagebus")
116	(group "messagebus")
117	(system? #t)
118	(comment "D-Bus system bus user")
119	(home-directory "/var/run/dbus")
120	(shell
121	#~(string-append #$shadow "/sbin/nologin")))))
122	(activate #~(begin
123	(use-modules (guix build utils))
124
125	(mkdir-p "/var/run/dbus")
126
127	(let ((user (getpwnam "messagebus")))
128	(chown "/var/run/dbus"
129	(passwd:uid user) (passwd:gid user)))
130
131	(unless (file-exists? "/etc/machine-id")
132	(format #t "creating /etc/machine-id...~%")
133	(let ((prog (string-append #$dbus "/bin/dbus-uuidgen")))
134	;; XXX: We can't use 'system' because the initrd's
135	;; guile system(3) only works when 'sh' is in $PATH.
136	(let ((pid (primitive-fork)))
137	(if (zero? pid)
138	(call-with-output-file "/etc/machine-id"
139	(lambda (port)
140	(close-fdes 1)
141	(dup2 (port->fdes port) 1)
142	(execl prog)))
143	(waitpid pid)))))))))))
144
145	\f
146	;;;
147	;;; Upower D-Bus service.
148	;;;
149
150	(define* (upower-configuration-file #:key watts-up-pro? poll-batteries?
151	ignore-lid? use-percentage-for-policy?
152	percentage-low percentage-critical
153	percentage-action time-low
154	time-critical time-action
155	critical-power-action)
156	"Return an upower-daemon configuration file."
157	(define (bool value)
158	(if value "true\n" "false\n"))
159
160	(text-file "UPower.conf"
161	(string-append
162	"[UPower]\n"
163	"EnableWattsUpPro=" (bool watts-up-pro?)
164	"NoPollBatteries=" (bool (not poll-batteries?))
165	"IgnoreLid=" (bool ignore-lid?)
166	"UsePercentageForPolicy=" (bool use-percentage-for-policy?)
167	"PercentageLow=" (number->string percentage-low) "\n"
168	"PercentageCritical=" (number->string percentage-critical) "\n"
169	"PercentageAction=" (number->string percentage-action) "\n"
170	"TimeLow=" (number->string time-low) "\n"
171	"TimeCritical=" (number->string time-critical) "\n"
172	"TimeAction=" (number->string time-action) "\n"
173	"CriticalPowerAction=" (match critical-power-action
174	('hybrid-sleep "HybridSleep")
175	('hibernate "Hibernate")
176	('power-off "PowerOff"))
177	"\n")))
178
179	(define* (upower-service #:key (upower upower)
180	(watts-up-pro? #f)
181	(poll-batteries? #t)
182	(ignore-lid? #f)
183	(use-percentage-for-policy? #f)
184	(percentage-low 10)
185	(percentage-critical 3)
186	(percentage-action 2)
187	(time-low 1200)
188	(time-critical 300)
189	(time-action 120)
190	(critical-power-action 'hybrid-sleep))
191	"Return a service that runs @uref{http://upower.freedesktop.org/,
192	@command{upowerd}}, a system-wide monitor for power consumption and battery
193	levels, with the given configuration settings. It implements the
194	@code{org.freedesktop.UPower} D-Bus interface, and is notably used by GNOME."
195	(mlet %store-monad ((config (upower-configuration-file
196	#:watts-up-pro? watts-up-pro?
197	#:poll-batteries? poll-batteries?
198	#:ignore-lid? ignore-lid?
199	#:use-percentage-for-policy? use-percentage-for-policy?
200	#:percentage-low percentage-low
201	#:percentage-critical percentage-critical
202	#:percentage-action percentage-action
203	#:time-low time-low
204	#:time-critical time-critical
205	#:time-action time-action
206	#:critical-power-action critical-power-action)))
207	(return
208	(service
209	(documentation "Run the UPower power and battery monitor.")
210	(provision '(upower-daemon))
211	(requirement '(dbus-system udev))
212
213	(start #~(make-forkexec-constructor
214	(list (string-append #$upower "/libexec/upowerd"))
215	#:environment-variables
216	(list (string-append "UPOWER_CONF_FILE_NAME=" #$config))))
217	(stop #~(make-kill-destructor))
218	(activate #~(begin
219	(use-modules (guix build utils))
220	(mkdir-p "/var/lib/upower")
221	(let ((user (getpwnam "upower")))
222	(chown "/var/lib/upower"
223	(passwd:uid user) (passwd:gid user)))))
224
225	(user-groups (list (user-group
226	(name "upower")
227	(system? #t))))
228	(user-accounts (list (user-account
229	(name "upower")
230	(group "upower")
231	(system? #t)
232	(comment "UPower daemon user")
233	(home-directory "/var/empty")
234	(shell
235	#~(string-append #$shadow "/sbin/nologin")))))))))
236
237	\f
238	;;;
239	;;; Colord D-Bus service.
240	;;;
241
242	(define* (colord-service #:key (colord colord))
243	"Return a service that runs @command{colord}, a system service with a D-Bus
244	interface to manage the color profiles of input and output devices such as
245	screens and scanners. It is notably used by the GNOME Color Manager graphical
246	tool. See @uref{http://www.freedesktop.org/software/colord/, the colord web
247	site} for more information."
248	(with-monad %store-monad
249	(return
250	(service
251	(documentation "Run the colord color management service.")
252	(provision '(colord-daemon))
253	(requirement '(dbus-system udev))
254
255	(start #~(make-forkexec-constructor
256	(list (string-append #$colord "/libexec/colord"))))
257	(stop #~(make-kill-destructor))
258	(activate #~(begin
259	(use-modules (guix build utils))
260	(mkdir-p "/var/lib/colord")
261	(let ((user (getpwnam "colord")))
262	(chown "/var/lib/colord"
263	(passwd:uid user) (passwd:gid user)))))
264
265	(user-groups (list (user-group
266	(name "colord")
267	(system? #t))))
268	(user-accounts (list (user-account
269	(name "colord")
270	(group "colord")
271	(system? #t)
272	(comment "colord daemon user")
273	(home-directory "/var/empty")
274	(shell
275	#~(string-append #$shadow "/sbin/nologin")))))))))
276
4467be21 LC	277	(define %desktop-services
	278	;; List of services typically useful for a "desktop" use case.
	279	(cons* (slim-service)
	280
	281	(avahi-service)
	282	(wicd-service)
	283	(upower-service)
	284	(colord-service)
	285	(dbus-service (list avahi wicd upower colord))
	286
	287	(ntp-service)
4467be21 LC	288
	289	(map (lambda (mservice)
	290	;; Provide an nscd ready to use nss-mdns.
	291	(mlet %store-monad ((service mservice))
	292	(if (memq 'nscd (service-provision service))
	293	(nscd-service (nscd-configuration)
	294	#:name-services (list nss-mdns))
	295	mservice)))
	296	%base-services)))
	297
fe1a39d3	298	;;; desktop.scm ends here