X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/adc90e0eac3cb326cd687f80514dad6a5240969d..5c3d77c3b14a9e87b4075efa4d7a877181e25665:/gnu/services/dbus.scm diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index e4ecd961c5..7b3c8100e2 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès +;;; Copyright © 2015 Sou Bunnbu ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,16 +19,25 @@ (define-module (gnu services dbus) #:use-module (gnu services) - #:use-module (gnu services dmd) + #:use-module (gnu services shepherd) #:use-module (gnu system shadow) - #:use-module (gnu packages glib) + #:use-module (gnu system pam) + #:use-module ((gnu packages glib) #:select (dbus)) + #:use-module (gnu packages polkit) #:use-module (gnu packages admin) #:use-module (guix gexp) + #:use-module ((guix packages) #:select (package-name)) #:use-module (guix records) #:use-module (srfi srfi-1) #:use-module (ice-9 match) - #:export (dbus-root-service-type - dbus-service)) + #:export (dbus-configuration + dbus-configuration? + dbus-root-service-type + dbus-service + wrapped-dbus-service + + polkit-service-type + polkit-service)) ;;; ;;; D-Bus. @@ -41,36 +51,81 @@ (services dbus-configuration-services ;list of (default '()))) -(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 +(define (system-service-directory services) + "Return the system service directory, containing @code{.service} files for +all the services that may be activated by the daemon." + (computed-file "dbus-system-services" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1)) + + (define files + (append-map (lambda (service) + (find-files + (string-append + service + "/share/dbus-1/") + "\\.service$")) + (list #$@services))) + + (mkdir #$output) + (for-each (lambda (file) + (symlink file + (string-append #$output "/" + (basename file)))) + files) + #t)))) + +(define (dbus-configuration-directory services) + "Return a directory contains the @code{system-local.conf} file for 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-syntax directives + (syntax-rules () + ;; Expand the given directives (SXML expressions) only if their + ;; key names a file that exists. + ((_ (name directory) rest ...) + (let ((dir directory)) + (if (file-exists? dir) + `((name ,dir) + ,@(directives rest ...)) + (directives rest ...)))) + ((_) + '()))) + (define (services->sxml services) ;; Return the SXML 'includedir' clauses for DIRS. `(busconfig + (servicehelper "/run/setuid-programs/dbus-daemon-launch-helper") + + ;; First, the '.service' files of services subject to activation. + ;; We use a fixed location under /etc because the setuid helper + ;; looks for them in that location and nowhere else. See + ;; . + (servicedir "/etc/dbus-1/system-services") + ,@(append-map (lambda (dir) - `((includedir - ,(string-append dir "/etc/dbus-1/system.d")) - (servicedir ;for '.service' files - ,(string-append dir "/share/dbus-1/services")) - (servicedir ;likewise, for auto-activation - ,(string-append - dir - "/share/dbus-1/system-services")))) + (directives + (includedir + (string-append dir "/etc/dbus-1/system.d")) + (includedir + (string-append dir "/share/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 clause for - ;; 'system.d', so create it. - (mkdir (string-append #$output "/system.d")) + ;; Provide /etc/dbus-1/system-services, which is where the setuid + ;; helper looks for system service files. + (symlink #$(system-service-directory services) + (string-append #$output "/system-services")) ;; 'system-local.conf' is automatically included by the default ;; 'system.conf', so this is where we stuff our own things. @@ -81,6 +136,12 @@ (computed-file "dbus-configuration" build)) +(define (dbus-etc-files config) + "Return a list of FILES for @var{etc-service-type} to build the +@code{/etc/dbus-1} directory." + (list `("dbus-1" ,(dbus-configuration-directory + (dbus-configuration-services config))))) + (define %dbus-accounts ;; Accounts used by the system bus. (list (user-group (name "messagebus") (system? #t)) @@ -90,7 +151,13 @@ (system? #t) (comment "D-Bus system bus user") (home-directory "/var/run/dbus") - (shell #~(string-append #$shadow "/sbin/nologin"))))) + (shell (file-append shadow "/sbin/nologin"))))) + +(define dbus-setuid-programs + ;; Return the file name of the setuid program that we need. + (match-lambda + (($ dbus services) + (list (file-append dbus "/libexec/dbus-daemon-launch-helper"))))) (define (dbus-activation config) "Return an activation gexp for D-Bus using @var{config}." @@ -101,53 +168,47 @@ (let ((user (getpwnam "messagebus"))) (chown "/var/run/dbus" - (passwd:uid user) (passwd:gid user))) + (passwd:uid user) (passwd:gid user)) + + ;; This directory contains the daemon's socket so it must be + ;; world-readable. + (chmod "/var/run/dbus" #o755)) (unless (file-exists? "/etc/machine-id") (format #t "creating /etc/machine-id...~%") - (let ((prog (string-append #$(dbus-configuration-dbus config) - "/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))))))) - -(define dbus-dmd-service + (invoke (string-append #$(dbus-configuration-dbus config) + "/bin/dbus-uuidgen") + "--ensure=/etc/machine-id")))) + +(define dbus-shepherd-service (match-lambda - (($ dbus services) - (let ((conf (dbus-configuration-directory dbus services))) - (list (dmd-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)))))))) + (($ dbus) + (list (shepherd-service + (documentation "Run the D-Bus system daemon.") + (provision '(dbus-system)) + (requirement '(user-processes syslogd)) + (start #~(make-forkexec-constructor + (list (string-append #$dbus "/bin/dbus-daemon") + "--nofork" "--system" "--syslog-only") + #:pid-file "/var/run/dbus/pid")) + (stop #~(make-kill-destructor))))))) (define dbus-root-service-type (service-type (name 'dbus) (extensions - (list (service-extension dmd-root-service-type - dbus-dmd-service) + (list (service-extension shepherd-root-service-type + dbus-shepherd-service) (service-extension activation-service-type dbus-activation) + (service-extension etc-service-type + dbus-etc-files) (service-extension account-service-type - (const %dbus-accounts)))) + (const %dbus-accounts)) + (service-extension setuid-program-service-type + dbus-setuid-programs))) ;; Extensions consist of lists of packages (representing D-Bus ;; services) that we just concatenate. - ;; - ;; FIXME: We need 'dbus-daemon-launch-helper' to be - ;; setuid-root for auto-activation to work. (compose concatenate) ;; The service's parameters field is extended by augmenting @@ -157,7 +218,12 @@ (inherit config) (services (append (dbus-configuration-services config) - services))))))) + services))))) + + (default-value (dbus-configuration)) + (description "Run the system-wide D-Bus inter-process message +bus. It allows programs and daemons to communicate and is also responsible +for spawning (@dfn{activating}) D-Bus services on demand."))) (define* (dbus-service #:key (dbus dbus) (services '())) "Return a service that runs the \"system bus\", using @var{dbus}, with @@ -175,4 +241,139 @@ and policy files. For example, to allow avahi-daemon to use the system bus, (dbus-configuration (dbus dbus) (services services)))) +(define (wrapped-dbus-service service program variables) + "Return a wrapper for @var{service}, a package containing a D-Bus service, +where @var{program} is wrapped such that @var{variables}, a list of name/value +tuples, are all set as environment variables when the bus daemon launches it." + (define wrapper + (program-file (string-append (package-name service) "-program-wrapper") + #~(begin + (use-modules (ice-9 match)) + + (for-each (match-lambda + ((variable value) + (setenv variable value))) + '#$variables) + + (apply execl (string-append #$service "/" #$program) + (string-append #$service "/" #$program) + (cdr (command-line)))))) + + (define build + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define service-directory + "/share/dbus-1/system-services") + + (mkdir-p (dirname (string-append #$output + service-directory))) + (copy-recursively (string-append #$service + service-directory) + (string-append #$output + service-directory)) + (symlink (string-append #$service "/etc") ;for etc/dbus-1 + (string-append #$output "/etc")) + + (for-each (lambda (file) + (substitute* file + (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$" + _ original-program arguments) + (string-append "Exec=" #$wrapper arguments + "\n")))) + (find-files #$output "\\.service$"))))) + + (computed-file (string-append (package-name service) "-wrapper") + build)) + + +;;; +;;; Polkit privilege management service. +;;; + +(define-record-type* + polkit-configuration make-polkit-configuration + polkit-configuration? + (polkit polkit-configuration-polkit ; + (default polkit)) + (actions polkit-configuration-actions ;list of + (default '()))) + +(define %polkit-accounts + (list (user-group (name "polkitd") (system? #t)) + (user-account + (name "polkitd") + (group "polkitd") + (system? #t) + (comment "Polkit daemon user") + (home-directory "/var/empty") + (shell "/run/current-system/profile/sbin/nologin")))) + +(define %polkit-pam-services + (list (unix-pam-service "polkit-1"))) + +(define (polkit-directory packages) + "Return a directory containing an @file{actions} and possibly a +@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}." + (with-imported-modules '((guix build union)) + (computed-file "etc-polkit-1" + #~(begin + (use-modules (guix build union) (srfi srfi-26)) + + (union-build #$output + (map (cut string-append <> + "/share/polkit-1") + (list #$@packages))))))) + +(define polkit-etc-files + (match-lambda + (($ polkit packages) + `(("polkit-1" ,(polkit-directory (cons polkit packages))))))) + +(define polkit-setuid-programs + (match-lambda + (($ polkit) + (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1") + (file-append polkit "/bin/pkexec"))))) + +(define polkit-service-type + (service-type (name 'polkit) + (extensions + (list (service-extension account-service-type + (const %polkit-accounts)) + (service-extension pam-root-service-type + (const %polkit-pam-services)) + (service-extension dbus-root-service-type + (compose + list + polkit-configuration-polkit)) + (service-extension etc-service-type + polkit-etc-files) + (service-extension setuid-program-service-type + polkit-setuid-programs))) + + ;; Extensions are lists of packages that provide polkit rules + ;; or actions under share/polkit-1/{actions,rules.d}. + (compose concatenate) + (extend (lambda (config actions) + (polkit-configuration + (inherit config) + (actions + (append (polkit-configuration-actions config) + actions))))) + + (default-value (polkit-configuration)))) + +(define* (polkit-service #:key (polkit polkit)) + "Return a service that runs the +@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege +management service}, which allows system administrators to grant access to +privileged operations in a structured way. By querying the Polkit service, a +privileged system component can know when it should grant additional +capabilities to ordinary users. For example, an ordinary user can be granted +the capability to suspend the system if the user is logged in locally." + (service polkit-service-type + (polkit-configuration (polkit polkit)))) + ;;; dbus.scm ends here