gnu/services/dbus.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   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.
  11 ;;;
  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.
  16 ;;;
  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/>.
  19
  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 packages glib) #:select (dbus))
  25   #:use-module (gnu packages admin)
  26   #:use-module (guix gexp)
  27   #:use-module (guix records)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (ice-9 match)
  30   #:export (dbus-configuration
  31             dbus-configuration?
  32             dbus-root-service-type
  33             dbus-service))
  34
  35 ;;;
  36 ;;; D-Bus.
  37 ;;;
  38
  39 (define-record-type* <dbus-configuration>
  40   dbus-configuration make-dbus-configuration
  41   dbus-configuration?
  42   (dbus      dbus-configuration-dbus              ;<package>
  43              (default dbus))
  44   (services  dbus-configuration-services          ;list of <package>
  45              (default '())))
  46
  47 (define (system-service-directory services)
  48   "Return the system service directory, containing @code{.service} files for
  49 all the services that may be activated by the daemon."
  50   (computed-file "dbus-system-services"
  51                  (with-imported-modules '((guix build utils))
  52                    #~(begin
  53                        (use-modules (guix build utils)
  54                                     (srfi srfi-1))
  55
  56                        (define files
  57                          (append-map (lambda (service)
  58                                        (find-files
  59                                         (string-append
  60                                          service
  61                                          "/share/dbus-1/system-services")
  62                                         "\\.service$"))
  63                                      (list #$@services)))
  64
  65                        (mkdir #$output)
  66                        (for-each (lambda (file)
  67                                    (symlink file
  68                                             (string-append #$output "/"
  69                                                            (basename file))))
  70                                  files)
  71                        #t))))
  72
  73 (define (dbus-configuration-directory services)
  74   "Return a directory contains the @code{system-local.conf} file for DBUS that
  75 includes the @code{etc/dbus-1/system.d} directories of each package listed in
  76 @var{services}."
  77   (define build
  78     #~(begin
  79         (use-modules (sxml simple)
  80                      (srfi srfi-1))
  81
  82         (define (services->sxml services)
  83           ;; Return the SXML 'includedir' clauses for DIRS.
  84           `(busconfig
  85             (servicehelper "/run/setuid-programs/dbus-daemon-launch-helper")
  86
  87             ;; First, the '.service' files of services subject to activation.
  88             ;; We use a fixed location under /etc because the setuid helper
  89             ;; looks for them in that location and nowhere else.  See
  90             ;; <https://bugs.freedesktop.org/show_bug.cgi?id=92458>.
  91             (servicedir "/etc/dbus-1/system-services")
  92
  93             ,@(append-map (lambda (dir)
  94                             `((includedir
  95                                ,(string-append dir "/etc/dbus-1/system.d"))
  96                               (servicedir       ;for '.service' files
  97                                ,(string-append dir "/share/dbus-1/services"))))
  98                           services)))
  99
 100         (mkdir #$output)
 101
 102         ;; Provide /etc/dbus-1/system-services, which is where the setuid
 103         ;; helper looks for system service files.
 104         (symlink #$(system-service-directory services)
 105                  (string-append #$output "/system-services"))
 106
 107         ;; 'system-local.conf' is automatically included by the default
 108         ;; 'system.conf', so this is where we stuff our own things.
 109         (call-with-output-file (string-append #$output "/system-local.conf")
 110           (lambda (port)
 111             (sxml->xml (services->sxml (list #$@services))
 112                        port)))))
 113
 114   (computed-file "dbus-configuration" build))
 115
 116 (define (dbus-etc-files config)
 117   "Return a list of FILES for @var{etc-service-type} to build the
 118 @code{/etc/dbus-1} directory."
 119   (list `("dbus-1" ,(dbus-configuration-directory
 120                      (dbus-configuration-services config)))))
 121
 122 (define %dbus-accounts
 123   ;; Accounts used by the system bus.
 124   (list (user-group (name "messagebus") (system? #t))
 125         (user-account
 126          (name "messagebus")
 127          (group "messagebus")
 128          (system? #t)
 129          (comment "D-Bus system bus user")
 130          (home-directory "/var/run/dbus")
 131          (shell (file-append shadow "/sbin/nologin")))))
 132
 133 (define dbus-setuid-programs
 134   ;; Return the file name of the setuid program that we need.
 135   (match-lambda
 136     (($ <dbus-configuration> dbus services)
 137      (list (file-append dbus "/libexec/dbus-daemon-launch-helper")))))
 138
 139 (define (dbus-activation config)
 140   "Return an activation gexp for D-Bus using @var{config}."
 141   #~(begin
 142       (use-modules (guix build utils))
 143
 144       (mkdir-p "/var/run/dbus")
 145
 146       (let ((user (getpwnam "messagebus")))
 147         (chown "/var/run/dbus"
 148                (passwd:uid user) (passwd:gid user)))
 149
 150       (unless (file-exists? "/etc/machine-id")
 151         (format #t "creating /etc/machine-id...~%")
 152         (let ((prog (string-append #$(dbus-configuration-dbus config)
 153                                    "/bin/dbus-uuidgen")))
 154           ;; XXX: We can't use 'system' because the initrd's
 155           ;; guile system(3) only works when 'sh' is in $PATH.
 156           (let ((pid (primitive-fork)))
 157             (if (zero? pid)
 158                 (call-with-output-file "/etc/machine-id"
 159                   (lambda (port)
 160                     (close-fdes 1)
 161                     (dup2 (port->fdes port) 1)
 162                     (execl prog)))
 163                 (waitpid pid)))))))
 164
 165 (define dbus-shepherd-service
 166   (match-lambda
 167     (($ <dbus-configuration> dbus)
 168      (list (shepherd-service
 169             (documentation "Run the D-Bus system daemon.")
 170             (provision '(dbus-system))
 171             (requirement '(user-processes))
 172             (start #~(make-forkexec-constructor
 173                       (list (string-append #$dbus "/bin/dbus-daemon")
 174                             "--nofork" "--system")
 175                       #:pid-file "/var/run/dbus/pid"))
 176             (stop #~(make-kill-destructor)))))))
 177
 178 (define dbus-root-service-type
 179   (service-type (name 'dbus)
 180                 (extensions
 181                  (list (service-extension shepherd-root-service-type
 182                                           dbus-shepherd-service)
 183                        (service-extension activation-service-type
 184                                           dbus-activation)
 185                        (service-extension etc-service-type
 186                                           dbus-etc-files)
 187                        (service-extension account-service-type
 188                                           (const %dbus-accounts))
 189                        (service-extension setuid-program-service-type
 190                                           dbus-setuid-programs)))
 191
 192                 ;; Extensions consist of lists of packages (representing D-Bus
 193                 ;; services) that we just concatenate.
 194                 (compose concatenate)
 195
 196                 ;; The service's parameters field is extended by augmenting
 197                 ;; its <dbus-configuration> 'services' field.
 198                 (extend (lambda (config services)
 199                           (dbus-configuration
 200                            (inherit config)
 201                            (services
 202                             (append (dbus-configuration-services config)
 203                                     services)))))))
 204
 205 (define* (dbus-service #:key (dbus dbus) (services '()))
 206   "Return a service that runs the \"system bus\", using @var{dbus}, with
 207 support for @var{services}.
 208
 209 @uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
 210 facility.  Its system bus is used to allow system services to communicate and
 211 be notified of system-wide events.
 212
 213 @var{services} must be a list of packages that provide an
 214 @file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
 215 and policy files.  For example, to allow avahi-daemon to use the system bus,
 216 @var{services} must be equal to @code{(list avahi)}."
 217   (service dbus-root-service-type
 218            (dbus-configuration (dbus dbus)
 219                                (services services))))
 220
 221 ;;; dbus.scm ends here