Commit | Line | Data |
---|---|---|
0adfe95a LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> | |
64643b90 | 3 | ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> |
0adfe95a LC |
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 dbus) | |
21 | #:use-module (gnu services) | |
0190c1c0 | 22 | #:use-module (gnu services shepherd) |
0adfe95a | 23 | #:use-module (gnu system shadow) |
cde04021 | 24 | #:use-module ((gnu packages glib) #:select (dbus/activation)) |
0adfe95a LC |
25 | #:use-module (gnu packages admin) |
26 | #:use-module (guix gexp) | |
27 | #:use-module (guix records) | |
28 | #:use-module (srfi srfi-1) | |
29 | #:use-module (ice-9 match) | |
30 | #:export (dbus-root-service-type | |
31 | dbus-service)) | |
32 | ||
33 | ;;; | |
34 | ;;; D-Bus. | |
35 | ;;; | |
36 | ||
37 | (define-record-type* <dbus-configuration> | |
38 | dbus-configuration make-dbus-configuration | |
39 | dbus-configuration? | |
40 | (dbus dbus-configuration-dbus ;<package> | |
cde04021 | 41 | (default dbus/activation)) |
0adfe95a LC |
42 | (services dbus-configuration-services ;list of <package> |
43 | (default '()))) | |
44 | ||
cde04021 LC |
45 | (define (system-service-directory services) |
46 | "Return the system service directory, containing @code{.service} files for | |
47 | all the services that may be activated by the daemon." | |
48 | (computed-file "dbus-system-services" | |
49 | #~(begin | |
50 | (use-modules (guix build utils) | |
51 | (srfi srfi-1)) | |
52 | ||
53 | (define files | |
54 | (append-map (lambda (service) | |
55 | (find-files (string-append | |
56 | service | |
57 | "/share/dbus-1/system-services") | |
58 | "\\.service$")) | |
59 | (list #$@services))) | |
60 | ||
61 | (mkdir #$output) | |
62 | (for-each (lambda (file) | |
63 | (symlink file | |
64 | (string-append #$output "/" | |
65 | (basename file)))) | |
66 | files) | |
67 | #t) | |
68 | #:modules '((guix build utils)))) | |
69 | ||
64643b90 SB |
70 | (define (dbus-configuration-directory services) |
71 | "Return a directory contains the @code{system-local.conf} file for DBUS that | |
72 | includes the @code{etc/dbus-1/system.d} directories of each package listed in | |
0adfe95a LC |
73 | @var{services}." |
74 | (define build | |
75 | #~(begin | |
76 | (use-modules (sxml simple) | |
77 | (srfi srfi-1)) | |
78 | ||
79 | (define (services->sxml services) | |
80 | ;; Return the SXML 'includedir' clauses for DIRS. | |
81 | `(busconfig | |
cde04021 LC |
82 | (servicehelper "/run/setuid-programs/dbus-daemon-launch-helper") |
83 | ||
84 | ;; First, the '.service' files of services subject to activation. | |
85 | ;; We use a fixed location under /etc because the setuid helper | |
86 | ;; looks for them in that location and nowhere else. See | |
87 | ;; <https://bugs.freedesktop.org/show_bug.cgi?id=92458>. | |
88 | (servicedir "/etc/dbus-1/system-services") | |
89 | ||
0adfe95a LC |
90 | ,@(append-map (lambda (dir) |
91 | `((includedir | |
92 | ,(string-append dir "/etc/dbus-1/system.d")) | |
cde04021 LC |
93 | (servicedir ;for '.service' files |
94 | ,(string-append dir "/share/dbus-1/services")))) | |
0adfe95a LC |
95 | services))) |
96 | ||
97 | (mkdir #$output) | |
cde04021 LC |
98 | |
99 | ;; Provide /etc/dbus-1/system-services, which is where the setuid | |
100 | ;; helper looks for system service files. | |
101 | (symlink #$(system-service-directory services) | |
102 | (string-append #$output "/system-services")) | |
103 | ||
0adfe95a LC |
104 | ;; 'system-local.conf' is automatically included by the default |
105 | ;; 'system.conf', so this is where we stuff our own things. | |
106 | (call-with-output-file (string-append #$output "/system-local.conf") | |
107 | (lambda (port) | |
108 | (sxml->xml (services->sxml (list #$@services)) | |
109 | port))))) | |
110 | ||
111 | (computed-file "dbus-configuration" build)) | |
112 | ||
64643b90 SB |
113 | (define (dbus-etc-files config) |
114 | "Return a list of FILES for @var{etc-service-type} to build the | |
115 | @code{/etc/dbus-1} directory." | |
116 | (list `("dbus-1" ,(dbus-configuration-directory | |
117 | (dbus-configuration-services config))))) | |
118 | ||
0adfe95a LC |
119 | (define %dbus-accounts |
120 | ;; Accounts used by the system bus. | |
121 | (list (user-group (name "messagebus") (system? #t)) | |
122 | (user-account | |
123 | (name "messagebus") | |
124 | (group "messagebus") | |
125 | (system? #t) | |
126 | (comment "D-Bus system bus user") | |
127 | (home-directory "/var/run/dbus") | |
128 | (shell #~(string-append #$shadow "/sbin/nologin"))))) | |
129 | ||
cde04021 LC |
130 | (define dbus-setuid-programs |
131 | ;; Return the file name of the setuid program that we need. | |
132 | (match-lambda | |
133 | (($ <dbus-configuration> dbus services) | |
134 | (list #~(string-append #$dbus "/libexec/dbus-daemon-launch-helper"))))) | |
135 | ||
0adfe95a LC |
136 | (define (dbus-activation config) |
137 | "Return an activation gexp for D-Bus using @var{config}." | |
138 | #~(begin | |
139 | (use-modules (guix build utils)) | |
140 | ||
141 | (mkdir-p "/var/run/dbus") | |
142 | ||
143 | (let ((user (getpwnam "messagebus"))) | |
144 | (chown "/var/run/dbus" | |
145 | (passwd:uid user) (passwd:gid user))) | |
146 | ||
147 | (unless (file-exists? "/etc/machine-id") | |
148 | (format #t "creating /etc/machine-id...~%") | |
149 | (let ((prog (string-append #$(dbus-configuration-dbus config) | |
150 | "/bin/dbus-uuidgen"))) | |
151 | ;; XXX: We can't use 'system' because the initrd's | |
152 | ;; guile system(3) only works when 'sh' is in $PATH. | |
153 | (let ((pid (primitive-fork))) | |
154 | (if (zero? pid) | |
155 | (call-with-output-file "/etc/machine-id" | |
156 | (lambda (port) | |
157 | (close-fdes 1) | |
158 | (dup2 (port->fdes port) 1) | |
159 | (execl prog))) | |
160 | (waitpid pid))))))) | |
161 | ||
d4053c71 | 162 | (define dbus-shepherd-service |
4a663ca4 LC |
163 | (match-lambda |
164 | (($ <dbus-configuration> dbus) | |
d4053c71 | 165 | (list (shepherd-service |
4a663ca4 LC |
166 | (documentation "Run the D-Bus system daemon.") |
167 | (provision '(dbus-system)) | |
168 | (requirement '(user-processes)) | |
169 | (start #~(make-forkexec-constructor | |
170 | (list (string-append #$dbus "/bin/dbus-daemon") | |
171 | "--nofork" "--system"))) | |
172 | (stop #~(make-kill-destructor))))))) | |
0adfe95a LC |
173 | |
174 | (define dbus-root-service-type | |
175 | (service-type (name 'dbus) | |
176 | (extensions | |
d4053c71 AK |
177 | (list (service-extension shepherd-root-service-type |
178 | dbus-shepherd-service) | |
0adfe95a LC |
179 | (service-extension activation-service-type |
180 | dbus-activation) | |
64643b90 SB |
181 | (service-extension etc-service-type |
182 | dbus-etc-files) | |
0adfe95a | 183 | (service-extension account-service-type |
cde04021 LC |
184 | (const %dbus-accounts)) |
185 | (service-extension setuid-program-service-type | |
186 | dbus-setuid-programs))) | |
0adfe95a LC |
187 | |
188 | ;; Extensions consist of lists of packages (representing D-Bus | |
189 | ;; services) that we just concatenate. | |
0adfe95a LC |
190 | (compose concatenate) |
191 | ||
192 | ;; The service's parameters field is extended by augmenting | |
193 | ;; its <dbus-configuration> 'services' field. | |
194 | (extend (lambda (config services) | |
195 | (dbus-configuration | |
196 | (inherit config) | |
197 | (services | |
198 | (append (dbus-configuration-services config) | |
199 | services))))))) | |
200 | ||
cde04021 | 201 | (define* (dbus-service #:key (dbus dbus/activation) (services '())) |
0adfe95a LC |
202 | "Return a service that runs the \"system bus\", using @var{dbus}, with |
203 | support for @var{services}. | |
204 | ||
205 | @uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication | |
206 | facility. Its system bus is used to allow system services to communicate and | |
207 | be notified of system-wide events. | |
208 | ||
209 | @var{services} must be a list of packages that provide an | |
210 | @file{etc/dbus-1/system.d} directory containing additional D-Bus configuration | |
211 | and policy files. For example, to allow avahi-daemon to use the system bus, | |
212 | @var{services} must be equal to @code{(list avahi)}." | |
213 | (service dbus-root-service-type | |
214 | (dbus-configuration (dbus dbus) | |
215 | (services services)))) | |
216 | ||
217 | ;;; dbus.scm ends here |