Commit | Line | Data |
---|---|---|
0adfe95a LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (gnu services dbus) | |
20 | #:use-module (gnu services) | |
21 | #:use-module (gnu services dmd) | |
22 | #:use-module (gnu system shadow) | |
23 | #:use-module (gnu packages glib) | |
24 | #:use-module (gnu packages admin) | |
25 | #:use-module (guix gexp) | |
26 | #:use-module (guix records) | |
27 | #:use-module (srfi srfi-1) | |
28 | #:use-module (ice-9 match) | |
29 | #:export (dbus-root-service-type | |
30 | dbus-service)) | |
31 | ||
32 | ;;; | |
33 | ;;; D-Bus. | |
34 | ;;; | |
35 | ||
36 | (define-record-type* <dbus-configuration> | |
37 | dbus-configuration make-dbus-configuration | |
38 | dbus-configuration? | |
39 | (dbus dbus-configuration-dbus ;<package> | |
40 | (default dbus)) | |
41 | (services dbus-configuration-services ;list of <package> | |
42 | (default '()))) | |
43 | ||
44 | (define (dbus-configuration-directory dbus services) | |
45 | "Return a configuration directory for @var{dbus} that includes the | |
46 | @code{etc/dbus-1/system.d} directories of each package listed in | |
47 | @var{services}." | |
48 | (define build | |
49 | #~(begin | |
50 | (use-modules (sxml simple) | |
51 | (srfi srfi-1)) | |
52 | ||
53 | (define (services->sxml services) | |
54 | ;; Return the SXML 'includedir' clauses for DIRS. | |
55 | `(busconfig | |
56 | ,@(append-map (lambda (dir) | |
57 | `((includedir | |
58 | ,(string-append dir "/etc/dbus-1/system.d")) | |
59 | (servicedir ;for '.service' files | |
60 | ,(string-append dir "/share/dbus-1/services")) | |
61 | (servicedir ;likewise, for auto-activation | |
62 | ,(string-append | |
63 | dir | |
64 | "/share/dbus-1/system-services")))) | |
65 | services))) | |
66 | ||
67 | (mkdir #$output) | |
68 | (copy-file (string-append #$dbus "/etc/dbus-1/system.conf") | |
69 | (string-append #$output "/system.conf")) | |
70 | ||
71 | ;; The default 'system.conf' has an <includedir> clause for | |
72 | ;; 'system.d', so create it. | |
73 | (mkdir (string-append #$output "/system.d")) | |
74 | ||
75 | ;; 'system-local.conf' is automatically included by the default | |
76 | ;; 'system.conf', so this is where we stuff our own things. | |
77 | (call-with-output-file (string-append #$output "/system-local.conf") | |
78 | (lambda (port) | |
79 | (sxml->xml (services->sxml (list #$@services)) | |
80 | port))))) | |
81 | ||
82 | (computed-file "dbus-configuration" build)) | |
83 | ||
84 | (define %dbus-accounts | |
85 | ;; Accounts used by the system bus. | |
86 | (list (user-group (name "messagebus") (system? #t)) | |
87 | (user-account | |
88 | (name "messagebus") | |
89 | (group "messagebus") | |
90 | (system? #t) | |
91 | (comment "D-Bus system bus user") | |
92 | (home-directory "/var/run/dbus") | |
93 | (shell #~(string-append #$shadow "/sbin/nologin"))))) | |
94 | ||
95 | (define (dbus-activation config) | |
96 | "Return an activation gexp for D-Bus using @var{config}." | |
97 | #~(begin | |
98 | (use-modules (guix build utils)) | |
99 | ||
100 | (mkdir-p "/var/run/dbus") | |
101 | ||
102 | (let ((user (getpwnam "messagebus"))) | |
103 | (chown "/var/run/dbus" | |
104 | (passwd:uid user) (passwd:gid user))) | |
105 | ||
106 | (unless (file-exists? "/etc/machine-id") | |
107 | (format #t "creating /etc/machine-id...~%") | |
108 | (let ((prog (string-append #$(dbus-configuration-dbus config) | |
109 | "/bin/dbus-uuidgen"))) | |
110 | ;; XXX: We can't use 'system' because the initrd's | |
111 | ;; guile system(3) only works when 'sh' is in $PATH. | |
112 | (let ((pid (primitive-fork))) | |
113 | (if (zero? pid) | |
114 | (call-with-output-file "/etc/machine-id" | |
115 | (lambda (port) | |
116 | (close-fdes 1) | |
117 | (dup2 (port->fdes port) 1) | |
118 | (execl prog))) | |
119 | (waitpid pid))))))) | |
120 | ||
121 | (define dbus-dmd-service | |
122 | (match-lambda | |
123 | (($ <dbus-configuration> dbus services) | |
124 | (let ((conf (dbus-configuration-directory dbus services))) | |
125 | (list (dmd-service | |
126 | (documentation "Run the D-Bus system daemon.") | |
127 | (provision '(dbus-system)) | |
128 | (requirement '(user-processes)) | |
129 | (start #~(make-forkexec-constructor | |
130 | (list (string-append #$dbus "/bin/dbus-daemon") | |
131 | "--nofork" | |
132 | (string-append "--config-file=" #$conf | |
133 | "/system.conf")))) | |
134 | (stop #~(make-kill-destructor)))))))) | |
135 | ||
136 | (define dbus-root-service-type | |
137 | (service-type (name 'dbus) | |
138 | (extensions | |
139 | (list (service-extension dmd-root-service-type | |
140 | dbus-dmd-service) | |
141 | (service-extension activation-service-type | |
142 | dbus-activation) | |
143 | (service-extension account-service-type | |
144 | (const %dbus-accounts)))) | |
145 | ||
146 | ;; Extensions consist of lists of packages (representing D-Bus | |
147 | ;; services) that we just concatenate. | |
148 | ;; | |
149 | ;; FIXME: We need 'dbus-daemon-launch-helper' to be | |
150 | ;; setuid-root for auto-activation to work. | |
151 | (compose concatenate) | |
152 | ||
153 | ;; The service's parameters field is extended by augmenting | |
154 | ;; its <dbus-configuration> 'services' field. | |
155 | (extend (lambda (config services) | |
156 | (dbus-configuration | |
157 | (inherit config) | |
158 | (services | |
159 | (append (dbus-configuration-services config) | |
160 | services))))))) | |
161 | ||
162 | (define* (dbus-service #:key (dbus dbus) (services '())) | |
163 | "Return a service that runs the \"system bus\", using @var{dbus}, with | |
164 | support for @var{services}. | |
165 | ||
166 | @uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication | |
167 | facility. Its system bus is used to allow system services to communicate and | |
168 | be notified of system-wide events. | |
169 | ||
170 | @var{services} must be a list of packages that provide an | |
171 | @file{etc/dbus-1/system.d} directory containing additional D-Bus configuration | |
172 | and policy files. For example, to allow avahi-daemon to use the system bus, | |
173 | @var{services} must be equal to @code{(list avahi)}." | |
174 | (service dbus-root-service-type | |
175 | (dbus-configuration (dbus dbus) | |
176 | (services services)))) | |
177 | ||
178 | ;;; dbus.scm ends here |