123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318 |
- ;;; GNU Guix --- Functional package management for GNU
- ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
- ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
- ;;;
- ;;; This file is part of GNU Guix.
- ;;;
- ;;; GNU Guix is free software; you can redistribute it and/or modify it
- ;;; under the terms of the GNU General Public License as published by
- ;;; the Free Software Foundation; either version 3 of the License, or (at
- ;;; your option) any later version.
- ;;;
- ;;; GNU Guix is distributed in the hope that it will be useful, but
- ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;;; GNU General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU General Public License
- ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
- (define-module (gnu services dbus)
- #:use-module (gnu services)
- #:use-module (gnu services shepherd)
- #:use-module (gnu system shadow)
- #: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 records)
- #:use-module (srfi srfi-1)
- #:use-module (ice-9 match)
- #:export (dbus-configuration
- dbus-configuration?
- dbus-root-service-type
- dbus-service
- polkit-service-type
- polkit-service))
- ;;;
- ;;; D-Bus.
- ;;;
- (define-record-type* <dbus-configuration>
- dbus-configuration make-dbus-configuration
- dbus-configuration?
- (dbus dbus-configuration-dbus ;<package>
- (default dbus))
- (services dbus-configuration-services ;list of <package>
- (default '())))
- (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/system-services")
- "\\.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 (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
- ;; <https://bugs.freedesktop.org/show_bug.cgi?id=92458>.
- (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"))))
- services)))
- (mkdir #$output)
- ;; 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.
- (call-with-output-file (string-append #$output "/system-local.conf")
- (lambda (port)
- (sxml->xml (services->sxml (list #$@services))
- port)))))
- (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))
- (user-account
- (name "messagebus")
- (group "messagebus")
- (system? #t)
- (comment "D-Bus system bus user")
- (home-directory "/var/run/dbus")
- (shell (file-append shadow "/sbin/nologin")))))
- (define dbus-setuid-programs
- ;; Return the file name of the setuid program that we need.
- (match-lambda
- (($ <dbus-configuration> 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}."
- #~(begin
- (use-modules (guix build utils))
- (mkdir-p "/var/run/dbus")
- (let ((user (getpwnam "messagebus")))
- (chown "/var/run/dbus"
- (passwd:uid user) (passwd:gid user)))
- (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-shepherd-service
- (match-lambda
- (($ <dbus-configuration> dbus)
- (list (shepherd-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" "--system")
- #:pid-file "/var/run/dbus/pid"))
- (stop #~(make-kill-destructor)))))))
- (define dbus-root-service-type
- (service-type (name 'dbus)
- (extensions
- (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))
- (service-extension setuid-program-service-type
- dbus-setuid-programs)))
- ;; Extensions consist of lists of packages (representing D-Bus
- ;; services) that we just concatenate.
- (compose concatenate)
- ;; The service's parameters field is extended by augmenting
- ;; its <dbus-configuration> 'services' field.
- (extend (lambda (config services)
- (dbus-configuration
- (inherit config)
- (services
- (append (dbus-configuration-services config)
- services)))))
- (default-value (dbus-configuration))))
- (define* (dbus-service #:key (dbus dbus) (services '()))
- "Return a service that runs the \"system bus\", using @var{dbus}, with
- support for @var{services}.
- @uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
- facility. Its system bus is used to allow system services to communicate and
- be notified of system-wide events.
- @var{services} must be a list of packages that provide an
- @file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
- and policy files. For example, to allow avahi-daemon to use the system bus,
- @var{services} must be equal to @code{(list avahi)}."
- (service dbus-root-service-type
- (dbus-configuration (dbus dbus)
- (services services))))
- ;;;
- ;;; Polkit privilege management service.
- ;;;
- (define-record-type* <polkit-configuration>
- polkit-configuration make-polkit-configuration
- polkit-configuration?
- (polkit polkit-configuration-polkit ;<package>
- (default polkit))
- (actions polkit-configuration-actions ;list of <package>
- (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-configuration> polkit packages)
- `(("polkit-1" ,(polkit-directory (cons polkit packages)))))))
- (define polkit-setuid-programs
- (match-lambda
- (($ <polkit-configuration> 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
|