projects/guix·blob javascript-team · refs

481 lines · 19.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013-2017, 2019-2021, 2024 Ludovic Courtès <[email protected]>
3;;; Copyright © 2015 Sou Bunnbu <[email protected]>
4;;; Copyright © 2021 Maxime Devos <[email protected]>
5;;; Copyright © 2021 Brice Waegeneire <[email protected]>
6;;; Copyright © 2024 Tobias Geerinckx-Rice <[email protected]>
7;;;
8;;; This file is part of GNU Guix.
9;;;
10;;; GNU Guix is free software; you can redistribute it and/or modify it
11;;; under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 3 of the License, or (at
13;;; your option) any later version.
14;;;
15;;; GNU Guix is distributed in the hope that it will be useful, but
16;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22
23(define-module (gnu services dbus)
24 #:use-module (gnu services)
25 #:use-module (gnu services shepherd)
26 #:use-module (gnu system privilege)
27 #:use-module (gnu system shadow)
28 #:use-module (gnu system pam)
29 #:use-module ((gnu packages glib) #:select (dbus))
30 #:use-module (gnu packages polkit)
31 #:use-module (gnu packages admin)
32 #:use-module (gnu packages freedesktop)
33 #:use-module (guix deprecation)
34 #:use-module (guix gexp)
35 #:use-module ((guix packages) #:select (package-name))
36 #:use-module (guix records)
37 #:use-module (guix modules)
38 #:use-module (srfi srfi-1)
39 #:use-module (ice-9 match)
40 #:export (dbus-configuration
41 dbus-configuration?
42 dbus-root-service-type
43 dbus-service ; deprecated
44 wrapped-dbus-service
45
46 polkit-configuration
47 polkit-configuration?
48 polkit-service-type
49 polkit-service ; deprecated
50
51 rtkit-configuration
52 rtkit-service-type))
53
54;;;
55;;; D-Bus.
56;;;
57
58(define-record-type* <dbus-configuration>
59 dbus-configuration make-dbus-configuration
60 dbus-configuration?
61 (dbus dbus-configuration-dbus ;file-like
62 (default dbus))
63 (services dbus-configuration-services ;list of <package>
64 (default '()))
65 (verbose? dbus-configuration-verbose? ;boolean
66 (default #f)))
67
68(define (system-service-directory services)
69 "Return the system service directory, containing @code{.service} files for
70all the services that may be activated by the daemon."
71 (computed-file "dbus-system-services"
72 (with-imported-modules '((guix build utils))
73 #~(begin
74 (use-modules (guix build utils)
75 (srfi srfi-1))
76
77 (define files
78 (append-map (lambda (service)
79 (find-files
80 (string-append
81 service
82 "/share/dbus-1/")
83 "\\.service$"))
84 (list #$@services)))
85
86 (mkdir #$output)
87 (for-each (lambda (file)
88 (symlink file
89 (string-append #$output "/"
90 (basename file))))
91 files)
92 #t))))
93
94(define (dbus-configuration-directory services)
95 "Return a directory contains the @code{system-local.conf} file for DBUS that
96includes the @code{etc/dbus-1/system.d} directories of each package listed in
97@var{services}."
98 (define build
99 #~(begin
100 (use-modules (sxml simple)
101 (srfi srfi-1))
102
103 (define-syntax directives
104 (syntax-rules ()
105 ;; Expand the given directives (SXML expressions) only if their
106 ;; key names a file that exists.
107 ((_ (name directory) rest ...)
108 (let ((dir directory))
109 (if (file-exists? dir)
110 `((name ,dir)
111 ,@(directives rest ...))
112 (directives rest ...))))
113 ((_)
114 '())))
115
116 (define (services->sxml services)
117 ;; Return the SXML 'includedir' clauses for DIRS.
118 `(busconfig
119 ;; Increase this timeout to 300 seconds to work around race-y
120 ;; failures such as <https://issues.guix.gnu.org/52051> on slow
121 ;; computers with slow I/O.
122 (limit (@ (name "auth_timeout")) "300000")
123 (servicehelper "/run/privileged/bin/dbus-daemon-launch-helper")
124
125 ;; First, the '.service' files of services subject to activation.
126 ;; We use a fixed location under /etc because the setuid helper
127 ;; looks for them in that location and nowhere else. See
128 ;; <https://bugs.freedesktop.org/show_bug.cgi?id=92458>.
129 (servicedir "/etc/dbus-1/system-services")
130
131 ,@(append-map (lambda (dir)
132 (directives
133 (includedir
134 (string-append dir "/etc/dbus-1/system.d"))
135 (includedir
136 (string-append dir "/share/dbus-1/system.d"))
137 (servicedir ;for '.service' files
138 (string-append dir "/share/dbus-1/services"))))
139 services)))
140
141 (mkdir #$output)
142
143 ;; Provide /etc/dbus-1/system-services, which is where the setuid
144 ;; helper looks for system service files.
145 (symlink #$(system-service-directory services)
146 (string-append #$output "/system-services"))
147
148 ;; 'system-local.conf' is automatically included by the default
149 ;; 'system.conf', so this is where we stuff our own things.
150 (call-with-output-file (string-append #$output "/system-local.conf")
151 (lambda (port)
152 (sxml->xml (services->sxml (list #$@services))
153 port)))))
154
155 (computed-file "dbus-configuration" build))
156
157(define (dbus-etc-files config)
158 "Return a list of FILES for @var{etc-service-type} to build the
159@code{/etc/dbus-1} directory."
160 (list `("dbus-1" ,(dbus-configuration-directory
161 (dbus-configuration-services config)))))
162
163(define %dbus-accounts
164 ;; Accounts used by the system bus.
165 (list (user-group (name "messagebus") (system? #t))
166 (user-account
167 (name "messagebus")
168 (group "messagebus")
169 (system? #t)
170 (comment "D-Bus system bus user")
171 (home-directory "/run/dbus")
172 (shell (file-append shadow "/sbin/nologin")))))
173
174(define dbus-privileged-programs
175 ;; Return a list of <privileged-program> for the program that we need.
176 (match-lambda
177 (($ <dbus-configuration> dbus services)
178 (list (privileged-program
179 (program (file-append
180 dbus "/libexec/dbus-daemon-launch-helper"))
181 (setuid? #t))))))
182
183(define (dbus-activation config)
184 "Return an activation gexp for D-Bus using @var{config}."
185 (with-imported-modules (source-module-closure
186 '((gnu build activation)
187 (guix build utils)))
188 #~(begin
189 (use-modules (gnu build activation)
190 (guix build utils))
191
192 (let ((user (getpwnam "messagebus")))
193 ;; This directory contains the daemon's socket so it must be
194 ;; world-readable.
195 (mkdir-p/perms "/run/dbus" user #o755))
196
197 (catch 'system-error
198 (lambda ()
199 (symlink "/run/dbus" "/var/run/dbus"))
200 (lambda args
201 (let ((errno (system-error-errno args)))
202 (cond
203 ((= errno EEXIST)
204 (let ((existing-name
205 (false-if-exception
206 (readlink "/var/run/dbus"))))
207 (unless (equal? existing-name "/run/dbus")
208 ;; Move the content of /var/run/dbus to /run/dbus, and
209 ;; retry.
210 (let ((dir (opendir "/var/run/dbus")))
211 (let loop ((next (readdir dir)))
212 (cond
213 ((eof-object? next) (closedir dir))
214 ((member next '("." "..")) (loop (readdir dir)))
215 (else
216 (begin
217 (rename-file (string-append "/var/run/dbus/" next)
218 (string-append "/run/dbus/" next))
219 (loop (readdir dir)))))))
220 (rmdir "/var/run/dbus")
221 (symlink "/run/dbus" "/var/run/dbus"))))
222 (else
223 (format (current-error-port)
224 "Failed to symlink /run/dbus to /var/run/dbus: ~s~%"
225 (strerror errno))
226 (error "cannot create /var/run/dbus"))))))
227
228 (unless (file-exists? "/etc/machine-id")
229 (format #t "creating /etc/machine-id...~%")
230 (invoke (string-append #$(dbus-configuration-dbus config)
231 "/bin/dbus-uuidgen")
232 "--ensure=/etc/machine-id")))))
233
234(define dbus-shepherd-service
235 (match-lambda
236 (($ <dbus-configuration> dbus _ verbose?)
237 (list (shepherd-service
238 (documentation "Run the D-Bus system daemon.")
239 (provision '(dbus-system))
240 (requirement '(user-processes syslogd))
241 (start #~(make-forkexec-constructor
242 (list (string-append #$dbus "/bin/dbus-daemon")
243 "--nofork" "--system")
244 #:log-file "/var/log/dbus-daemon.log"
245 #$@(if verbose?
246 ;; Since the verbose output goes to the console,
247 ;; not syslog, add a log file to capture it.
248 '(#:environment-variables '("DBUS_VERBOSE=1"))
249 '())
250 #:pid-file "/run/dbus/pid"))
251 (stop #~(make-kill-destructor)))))))
252
253(define dbus-root-service-type
254 (service-type (name 'dbus)
255 (extensions
256 (list (service-extension shepherd-root-service-type
257 dbus-shepherd-service)
258 (service-extension activation-service-type
259 dbus-activation)
260 (service-extension etc-service-type
261 dbus-etc-files)
262 (service-extension account-service-type
263 (const %dbus-accounts))
264 (service-extension privileged-program-service-type
265 dbus-privileged-programs)))
266
267 ;; Extensions consist of lists of packages (representing D-Bus
268 ;; services) that we just concatenate.
269 (compose concatenate)
270
271 ;; The service's parameters field is extended by augmenting
272 ;; its <dbus-configuration> 'services' field.
273 (extend (lambda (config services)
274 (dbus-configuration
275 (inherit config)
276 (services
277 (append (dbus-configuration-services config)
278 services)))))
279
280 (default-value (dbus-configuration))
281 (description "Run the system-wide D-Bus inter-process message
282bus. It allows programs and daemons to communicate and is also responsible
283for spawning (@dfn{activating}) D-Bus services on demand.")))
284
285(define-deprecated (dbus-service #:key (dbus dbus) (services '()) verbose?)
286 dbus-root-service-type
287 "Return a service that runs the \"system bus\", using @var{dbus}, with
288support for @var{services}. When @var{verbose?} is true, it causes the
289@samp{DBUS_VERBOSE} environment variable to be set to @samp{1}; a
290verbose-enabled D-Bus package such as @code{dbus-verbose} should be provided
291as @var{dbus} in this scenario.
292
293@uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
294facility. Its system bus is used to allow system services to communicate and
295be notified of system-wide events.
296
297@var{services} must be a list of packages that provide an
298@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
299and policy files. For example, to allow avahi-daemon to use the system bus,
300@var{services} must be equal to @code{(list avahi)}."
301 (service dbus-root-service-type
302 (dbus-configuration (dbus dbus)
303 (services services)
304 (verbose? verbose?))))
305
306(define (wrapped-dbus-service service program variables)
307 "Return a wrapper for @var{service}, a package containing a D-Bus service,
308where @var{program} is wrapped such that @var{variables}, a list of name/value
309tuples, are all set as environment variables when the bus daemon launches it."
310 (define wrapper
311 (program-file (string-append (package-name service) "-program-wrapper")
312 #~(begin
313 (use-modules (ice-9 match))
314
315 (for-each (match-lambda
316 ((variable value)
317 (setenv variable value)))
318 '#$variables)
319
320 (apply execl (string-append #$service "/" #$program)
321 (string-append #$service "/" #$program)
322 (cdr (command-line))))))
323
324 (define build
325 (with-imported-modules '((guix build utils))
326 #~(begin
327 (use-modules (guix build utils))
328
329 (define service-directory
330 "/share/dbus-1/system-services")
331
332 (mkdir-p (dirname (string-append #$output
333 service-directory)))
334 (copy-recursively (string-append #$service
335 service-directory)
336 (string-append #$output
337 service-directory))
338 (symlink (string-append #$service "/etc") ;for etc/dbus-1
339 (string-append #$output "/etc"))
340
341 (for-each (lambda (file)
342 (substitute* file
343 (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$"
344 _ original-program arguments)
345 (string-append "Exec=" #$wrapper arguments
346 "\n"))))
347 (find-files #$output "\\.service$")))))
348
349 (computed-file (string-append (package-name service) "-wrapper")
350 build))
351
352
353;;;
354;;; Polkit privilege management service.
355;;;
356
357(define-record-type* <polkit-configuration>
358 polkit-configuration make-polkit-configuration
359 polkit-configuration?
360 (polkit polkit-configuration-polkit ;file-like
361 (default polkit))
362 (actions polkit-configuration-actions ;list of file-like
363 (default '())))
364
365(define %polkit-accounts
366 (list (user-group (name "polkitd") (system? #t))
367 (user-account
368 (name "polkitd")
369 (group "polkitd")
370 (system? #t)
371 (comment "Polkit daemon user")
372 (home-directory "/var/empty")
373 (shell "/run/current-system/profile/sbin/nologin"))))
374
375(define %polkit-pam-services
376 (list (unix-pam-service "polkit-1")))
377
378(define (polkit-directory packages)
379 "Return a directory containing an @file{actions} and possibly a
380@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
381 (with-imported-modules '((guix build union))
382 (computed-file "etc-polkit-1"
383 #~(begin
384 (use-modules (guix build union) (srfi srfi-26))
385
386 (union-build #$output
387 (map (cut string-append <>
388 "/share/polkit-1")
389 (list #$@packages)))))))
390
391(define polkit-etc-files
392 (match-lambda
393 (($ <polkit-configuration> polkit packages)
394 `(("polkit-1" ,(polkit-directory (cons polkit packages)))))))
395
396(define polkit-privileged-programs
397 (match-lambda
398 (($ <polkit-configuration> polkit)
399 (map file-like->setuid-program
400 (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
401 (file-append polkit "/bin/pkexec"))))))
402
403(define polkit-service-type
404 (service-type (name 'polkit)
405 (extensions
406 (list (service-extension account-service-type
407 (const %polkit-accounts))
408 (service-extension pam-root-service-type
409 (const %polkit-pam-services))
410 (service-extension dbus-root-service-type
411 (compose
412 list
413 polkit-configuration-polkit))
414 (service-extension etc-service-type
415 polkit-etc-files)
416 (service-extension privileged-program-service-type
417 polkit-privileged-programs)))
418
419 ;; Extensions are lists of packages that provide polkit rules
420 ;; or actions under share/polkit-1/{actions,rules.d}.
421 (compose concatenate)
422 (extend (lambda (config actions)
423 (polkit-configuration
424 (inherit config)
425 (actions
426 (append (polkit-configuration-actions config)
427 actions)))))
428
429 (default-value (polkit-configuration))
430 (description
431 "Run the
432@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
433management service}, which allows system administrators to grant access to
434privileged operations in a structured way. Polkit is a requirement for most
435desktop environments, such as GNOME.")))
436
437(define-deprecated (polkit-service #:key (polkit polkit))
438 polkit-service-type
439 "Return a service that runs the
440@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
441management service}, which allows system administrators to grant access to
442privileged operations in a structured way. By querying the Polkit service, a
443privileged system component can know when it should grant additional
444capabilities to ordinary users. For example, an ordinary user can be granted
445the capability to suspend the system if the user is logged in locally."
446 (service polkit-service-type
447 (polkit-configuration (polkit polkit))))
448
449(define-record-type* <rtkit-configuration>
450 rtkit-configuration make-rtkit-configuration
451 rtkit-configuration?
452 (rtkit rtkit-configuration-rtkit
453 (default rtkit)))
454
455(define %rtkit-account
456 ;; Account used by rtkit.
457 (user-account
458 (name "rtkit")
459 (group "nogroup")
460 (system? #t)
461 (comment "Realtime kit user")
462 (home-directory "/var/empty")
463 (shell (file-append shadow "/sbin/nologin"))))
464
465(define rtkit-service-type
466 (let ((rtkit-package (compose list rtkit-configuration-rtkit)))
467 (service-type
468 (name 'rtkit)
469 (extensions
470 (list (service-extension
471 polkit-service-type rtkit-package)
472 (service-extension dbus-root-service-type rtkit-package)
473 (service-extension
474 account-service-type
475 (const (list %rtkit-account)))))
476 (default-value (rtkit-configuration))
477 (description
478 "Return a service that sets up D-Bus and PolKit so that the Realtime Kit
479daemon is readily usable."))))
480
481;;; dbus.scm ends here