gnu/services/dbus.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu services dbus)
  20   #:use-module (gnu services)
  21   #:use-module (gnu services dmd)
  22   #:use-module (gnu system shadow)
  23   #:use-module (gnu packages glib)
  24   #:use-module (gnu packages admin)
  25   #:use-module (guix gexp)
  26   #:use-module (guix records)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (ice-9 match)
  29   #:export (dbus-root-service-type
  30             dbus-service))
  31
  32 ;;;
  33 ;;; D-Bus.
  34 ;;;
  35
  36 (define-record-type* <dbus-configuration>
  37   dbus-configuration make-dbus-configuration
  38   dbus-configuration?
  39   (dbus      dbus-configuration-dbus              ;<package>
  40              (default dbus))
  41   (services  dbus-configuration-services          ;list of <package>
  42              (default '())))
  43
  44 (define (dbus-configuration-directory dbus services)
  45   "Return a configuration directory for @var{dbus} that includes the
  46 @code{etc/dbus-1/system.d} directories of each package listed in
  47 @var{services}."
  48   (define build
  49     #~(begin
  50         (use-modules (sxml simple)
  51                      (srfi srfi-1))
  52
  53         (define (services->sxml services)
  54           ;; Return the SXML 'includedir' clauses for DIRS.
  55           `(busconfig
  56             ,@(append-map (lambda (dir)
  57                             `((includedir
  58                                ,(string-append dir "/etc/dbus-1/system.d"))
  59                               (servicedir         ;for '.service' files
  60                                ,(string-append dir "/share/dbus-1/services"))
  61                               (servicedir       ;likewise, for auto-activation
  62                                ,(string-append
  63                                  dir
  64                                  "/share/dbus-1/system-services"))))
  65                           services)))
  66
  67         (mkdir #$output)
  68         (copy-file (string-append #$dbus "/etc/dbus-1/system.conf")
  69                    (string-append #$output "/system.conf"))
  70
  71         ;; The default 'system.conf' has an <includedir> clause for
  72         ;; 'system.d', so create it.
  73         (mkdir (string-append #$output "/system.d"))
  74
  75         ;; 'system-local.conf' is automatically included by the default
  76         ;; 'system.conf', so this is where we stuff our own things.
  77         (call-with-output-file (string-append #$output "/system-local.conf")
  78           (lambda (port)
  79             (sxml->xml (services->sxml (list #$@services))
  80                        port)))))
  81
  82   (computed-file "dbus-configuration" build))
  83
  84 (define %dbus-accounts
  85   ;; Accounts used by the system bus.
  86   (list (user-group (name "messagebus") (system? #t))
  87         (user-account
  88          (name "messagebus")
  89          (group "messagebus")
  90          (system? #t)
  91          (comment "D-Bus system bus user")
  92          (home-directory "/var/run/dbus")
  93          (shell #~(string-append #$shadow "/sbin/nologin")))))
  94
  95 (define (dbus-activation config)
  96   "Return an activation gexp for D-Bus using @var{config}."
  97   #~(begin
  98       (use-modules (guix build utils))
  99
 100       (mkdir-p "/var/run/dbus")
 101
 102       (let ((user (getpwnam "messagebus")))
 103         (chown "/var/run/dbus"
 104                (passwd:uid user) (passwd:gid user)))
 105
 106       (unless (file-exists? "/etc/machine-id")
 107         (format #t "creating /etc/machine-id...~%")
 108         (let ((prog (string-append #$(dbus-configuration-dbus config)
 109                                    "/bin/dbus-uuidgen")))
 110           ;; XXX: We can't use 'system' because the initrd's
 111           ;; guile system(3) only works when 'sh' is in $PATH.
 112           (let ((pid (primitive-fork)))
 113             (if (zero? pid)
 114                 (call-with-output-file "/etc/machine-id"
 115                   (lambda (port)
 116                     (close-fdes 1)
 117                     (dup2 (port->fdes port) 1)
 118                     (execl prog)))
 119                 (waitpid pid)))))))
 120
 121 (define dbus-dmd-service
 122   (match-lambda
 123     (($ <dbus-configuration> dbus services)
 124      (let ((conf (dbus-configuration-directory dbus services)))
 125        (list (dmd-service
 126               (documentation "Run the D-Bus system daemon.")
 127               (provision '(dbus-system))
 128               (requirement '(user-processes))
 129               (start #~(make-forkexec-constructor
 130                         (list (string-append #$dbus "/bin/dbus-daemon")
 131                               "--nofork"
 132                               (string-append "--config-file=" #$conf
 133                                              "/system.conf"))))
 134               (stop #~(make-kill-destructor))))))))
 135
 136 (define dbus-root-service-type
 137   (service-type (name 'dbus)
 138                 (extensions
 139                  (list (service-extension dmd-root-service-type
 140                                           dbus-dmd-service)
 141                        (service-extension activation-service-type
 142                                           dbus-activation)
 143                        (service-extension account-service-type
 144                                           (const %dbus-accounts))))
 145
 146                 ;; Extensions consist of lists of packages (representing D-Bus
 147                 ;; services) that we just concatenate.
 148                 ;;
 149                 ;; FIXME: We need 'dbus-daemon-launch-helper' to be
 150                 ;; setuid-root for auto-activation to work.
 151                 (compose concatenate)
 152
 153                 ;; The service's parameters field is extended by augmenting
 154                 ;; its <dbus-configuration> 'services' field.
 155                 (extend (lambda (config services)
 156                           (dbus-configuration
 157                            (inherit config)
 158                            (services
 159                             (append (dbus-configuration-services config)
 160                                     services)))))))
 161
 162 (define* (dbus-service #:key (dbus dbus) (services '()))
 163   "Return a service that runs the \"system bus\", using @var{dbus}, with
 164 support for @var{services}.
 165
 166 @uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
 167 facility.  Its system bus is used to allow system services to communicate and
 168 be notified of system-wide events.
 169
 170 @var{services} must be a list of packages that provide an
 171 @file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
 172 and policy files.  For example, to allow avahi-daemon to use the system bus,
 173 @var{services} must be equal to @code{(list avahi)}."
 174   (service dbus-root-service-type
 175            (dbus-configuration (dbus dbus)
 176                                (services services))))
 177
 178 ;;; dbus.scm ends here