1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
5 ;;; This file is part of GNU Guix.
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.
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.
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/>.
20 (define-module (gnu services dbus)
21 #:use-module (gnu services)
22 #:use-module (gnu services shepherd)
23 #:use-module (gnu system shadow)
24 #:use-module (gnu system pam)
25 #:use-module ((gnu packages glib) #:select (dbus))
26 #:use-module (gnu packages polkit)
27 #:use-module (gnu packages admin)
28 #:use-module (guix gexp)
29 #:use-module ((guix packages) #:select (package-name))
30 #:use-module (guix records)
31 #:use-module (srfi srfi-1)
32 #:use-module (ice-9 match)
33 #:export (dbus-configuration
35 dbus-root-service-type
46 (define-record-type* <dbus-configuration>
47 dbus-configuration make-dbus-configuration
49 (dbus dbus-configuration-dbus ;<package>
51 (services dbus-configuration-services ;list of <package>
54 (define (system-service-directory services)
55 "Return the system service directory, containing @code{.service} files for
56 all the services that may be activated by the daemon."
57 (computed-file "dbus-system-services"
58 (with-imported-modules '((guix build utils))
60 (use-modules (guix build utils)
64 (append-map (lambda (service)
73 (for-each (lambda (file)
75 (string-append #$output "/"
80 (define (dbus-configuration-directory services)
81 "Return a directory contains the @code{system-local.conf} file for DBUS that
82 includes the @code{etc/dbus-1/system.d} directories of each package listed in
86 (use-modules (sxml simple)
89 (define-syntax directives
91 ;; Expand the given directives (SXML expressions) only if their
92 ;; key names a file that exists.
93 ((_ (name directory) rest ...)
94 (let ((dir directory))
95 (if (file-exists? dir)
97 ,@(directives rest ...))
98 (directives rest ...))))
102 (define (services->sxml services)
103 ;; Return the SXML 'includedir' clauses for DIRS.
105 (servicehelper "/run/setuid-programs/dbus-daemon-launch-helper")
107 ;; First, the '.service' files of services subject to activation.
108 ;; We use a fixed location under /etc because the setuid helper
109 ;; looks for them in that location and nowhere else. See
110 ;; <https://bugs.freedesktop.org/show_bug.cgi?id=92458>.
111 (servicedir "/etc/dbus-1/system-services")
113 ,@(append-map (lambda (dir)
116 (string-append dir "/etc/dbus-1/system.d"))
118 (string-append dir "/share/dbus-1/system.d"))
119 (servicedir ;for '.service' files
120 (string-append dir "/share/dbus-1/services"))))
125 ;; Provide /etc/dbus-1/system-services, which is where the setuid
126 ;; helper looks for system service files.
127 (symlink #$(system-service-directory services)
128 (string-append #$output "/system-services"))
130 ;; 'system-local.conf' is automatically included by the default
131 ;; 'system.conf', so this is where we stuff our own things.
132 (call-with-output-file (string-append #$output "/system-local.conf")
134 (sxml->xml (services->sxml (list #$@services))
137 (computed-file "dbus-configuration" build))
139 (define (dbus-etc-files config)
140 "Return a list of FILES for @var{etc-service-type} to build the
141 @code{/etc/dbus-1} directory."
142 (list `("dbus-1" ,(dbus-configuration-directory
143 (dbus-configuration-services config)))))
145 (define %dbus-accounts
146 ;; Accounts used by the system bus.
147 (list (user-group (name "messagebus") (system? #t))
152 (comment "D-Bus system bus user")
153 (home-directory "/var/run/dbus")
154 (shell (file-append shadow "/sbin/nologin")))))
156 (define dbus-setuid-programs
157 ;; Return the file name of the setuid program that we need.
159 (($ <dbus-configuration> dbus services)
160 (list (file-append dbus "/libexec/dbus-daemon-launch-helper")))))
162 (define (dbus-activation config)
163 "Return an activation gexp for D-Bus using @var{config}."
165 (use-modules (guix build utils))
167 (mkdir-p "/var/run/dbus")
169 (let ((user (getpwnam "messagebus")))
170 (chown "/var/run/dbus"
171 (passwd:uid user) (passwd:gid user))
173 ;; This directory contains the daemon's socket so it must be
175 (chmod "/var/run/dbus" #o755))
177 (unless (file-exists? "/etc/machine-id")
178 (format #t "creating /etc/machine-id...~%")
179 (invoke (string-append #$(dbus-configuration-dbus config)
181 "--ensure=/etc/machine-id"))))
183 (define dbus-shepherd-service
185 (($ <dbus-configuration> dbus)
186 (list (shepherd-service
187 (documentation "Run the D-Bus system daemon.")
188 (provision '(dbus-system))
189 (requirement '(user-processes syslogd))
190 (start #~(make-forkexec-constructor
191 (list (string-append #$dbus "/bin/dbus-daemon")
192 "--nofork" "--system" "--syslog-only")
193 #:pid-file "/var/run/dbus/pid"))
194 (stop #~(make-kill-destructor)))))))
196 (define dbus-root-service-type
197 (service-type (name 'dbus)
199 (list (service-extension shepherd-root-service-type
200 dbus-shepherd-service)
201 (service-extension activation-service-type
203 (service-extension etc-service-type
205 (service-extension account-service-type
206 (const %dbus-accounts))
207 (service-extension setuid-program-service-type
208 dbus-setuid-programs)))
210 ;; Extensions consist of lists of packages (representing D-Bus
211 ;; services) that we just concatenate.
212 (compose concatenate)
214 ;; The service's parameters field is extended by augmenting
215 ;; its <dbus-configuration> 'services' field.
216 (extend (lambda (config services)
220 (append (dbus-configuration-services config)
223 (default-value (dbus-configuration))
224 (description "Run the system-wide D-Bus inter-process message
225 bus. It allows programs and daemons to communicate and is also responsible
226 for spawning (@dfn{activating}) D-Bus services on demand.")))
228 (define* (dbus-service #:key (dbus dbus) (services '()))
229 "Return a service that runs the \"system bus\", using @var{dbus}, with
230 support for @var{services}.
232 @uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
233 facility. Its system bus is used to allow system services to communicate and
234 be notified of system-wide events.
236 @var{services} must be a list of packages that provide an
237 @file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
238 and policy files. For example, to allow avahi-daemon to use the system bus,
239 @var{services} must be equal to @code{(list avahi)}."
240 (service dbus-root-service-type
241 (dbus-configuration (dbus dbus)
242 (services services))))
244 (define (wrapped-dbus-service service program variables)
245 "Return a wrapper for @var{service}, a package containing a D-Bus service,
246 where @var{program} is wrapped such that @var{variables}, a list of name/value
247 tuples, are all set as environment variables when the bus daemon launches it."
249 (program-file (string-append (package-name service) "-program-wrapper")
251 (use-modules (ice-9 match))
253 (for-each (match-lambda
255 (setenv variable value)))
258 (apply execl (string-append #$service "/" #$program)
259 (string-append #$service "/" #$program)
260 (cdr (command-line))))))
263 (with-imported-modules '((guix build utils))
265 (use-modules (guix build utils))
267 (define service-directory
268 "/share/dbus-1/system-services")
270 (mkdir-p (dirname (string-append #$output
272 (copy-recursively (string-append #$service
274 (string-append #$output
276 (symlink (string-append #$service "/etc") ;for etc/dbus-1
277 (string-append #$output "/etc"))
279 (for-each (lambda (file)
281 (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$"
282 _ original-program arguments)
283 (string-append "Exec=" #$wrapper arguments
285 (find-files #$output "\\.service$")))))
287 (computed-file (string-append (package-name service) "-wrapper")
292 ;;; Polkit privilege management service.
295 (define-record-type* <polkit-configuration>
296 polkit-configuration make-polkit-configuration
297 polkit-configuration?
298 (polkit polkit-configuration-polkit ;<package>
300 (actions polkit-configuration-actions ;list of <package>
303 (define %polkit-accounts
304 (list (user-group (name "polkitd") (system? #t))
309 (comment "Polkit daemon user")
310 (home-directory "/var/empty")
311 (shell "/run/current-system/profile/sbin/nologin"))))
313 (define %polkit-pam-services
314 (list (unix-pam-service "polkit-1")))
316 (define (polkit-directory packages)
317 "Return a directory containing an @file{actions} and possibly a
318 @file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
319 (with-imported-modules '((guix build union))
320 (computed-file "etc-polkit-1"
322 (use-modules (guix build union) (srfi srfi-26))
324 (union-build #$output
325 (map (cut string-append <>
327 (list #$@packages)))))))
329 (define polkit-etc-files
331 (($ <polkit-configuration> polkit packages)
332 `(("polkit-1" ,(polkit-directory (cons polkit packages)))))))
334 (define polkit-setuid-programs
336 (($ <polkit-configuration> polkit)
337 (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
338 (file-append polkit "/bin/pkexec")))))
340 (define polkit-service-type
341 (service-type (name 'polkit)
343 (list (service-extension account-service-type
344 (const %polkit-accounts))
345 (service-extension pam-root-service-type
346 (const %polkit-pam-services))
347 (service-extension dbus-root-service-type
350 polkit-configuration-polkit))
351 (service-extension etc-service-type
353 (service-extension setuid-program-service-type
354 polkit-setuid-programs)))
356 ;; Extensions are lists of packages that provide polkit rules
357 ;; or actions under share/polkit-1/{actions,rules.d}.
358 (compose concatenate)
359 (extend (lambda (config actions)
360 (polkit-configuration
363 (append (polkit-configuration-actions config)
366 (default-value (polkit-configuration))))
368 (define* (polkit-service #:key (polkit polkit))
369 "Return a service that runs the
370 @uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
371 management service}, which allows system administrators to grant access to
372 privileged operations in a structured way. By querying the Polkit service, a
373 privileged system component can know when it should grant additional
374 capabilities to ordinary users. For example, an ordinary user can be granted
375 the capability to suspend the system if the user is logged in locally."
376 (service polkit-service-type
377 (polkit-configuration (polkit polkit))))
379 ;;; dbus.scm ends here