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 system pam)
  25   #:use-module ((gnu packages glib) #:select (dbus))
  26   #:use-module (gnu packages polkit)
  27   #:use-module (gnu packages admin)
  28   #:use-module (guix gexp)
  29   #:use-module (guix records)
  30   #:use-module (srfi srfi-1)
  31   #:use-module (ice-9 match)
  32   #:export (dbus-configuration
  33             dbus-configuration?
  34             dbus-root-service-type
  35             dbus-service
  36
  37             polkit-service-type
  38             polkit-service))
  39
  40 ;;;
  41 ;;; D-Bus.
  42 ;;;
  43
  44 (define-record-type* <dbus-configuration>
  45   dbus-configuration make-dbus-configuration
  46   dbus-configuration?
  47   (dbus      dbus-configuration-dbus              ;<package>
  48              (default dbus))
  49   (services  dbus-configuration-services          ;list of <package>
  50              (default '())))
  51
  52 (define (system-service-directory services)
  53   "Return the system service directory, containing @code{.service} files for
  54 all the services that may be activated by the daemon."
  55   (computed-file "dbus-system-services"
  56                  (with-imported-modules '((guix build utils))
  57                    #~(begin
  58                        (use-modules (guix build utils)
  59                                     (srfi srfi-1))
  60
  61                        (define files
  62                          (append-map (lambda (service)
  63                                        (find-files
  64                                         (string-append
  65                                          service
  66                                          "/share/dbus-1/system-services")
  67                                         "\\.service$"))
  68                                      (list #$@services)))
  69
  70                        (mkdir #$output)
  71                        (for-each (lambda (file)
  72                                    (symlink file
  73                                             (string-append #$output "/"
  74                                                            (basename file))))
  75                                  files)
  76                        #t))))
  77
  78 (define (dbus-configuration-directory services)
  79   "Return a directory contains the @code{system-local.conf} file for DBUS that
  80 includes the @code{etc/dbus-1/system.d} directories of each package listed in
  81 @var{services}."
  82   (define build
  83     #~(begin
  84         (use-modules (sxml simple)
  85                      (srfi srfi-1))
  86
  87         (define (services->sxml services)
  88           ;; Return the SXML 'includedir' clauses for DIRS.
  89           `(busconfig
  90             (servicehelper "/run/setuid-programs/dbus-daemon-launch-helper")
  91
  92             ;; First, the '.service' files of services subject to activation.
  93             ;; We use a fixed location under /etc because the setuid helper
  94             ;; looks for them in that location and nowhere else.  See
  95             ;; <https://bugs.freedesktop.org/show_bug.cgi?id=92458>.
  96             (servicedir "/etc/dbus-1/system-services")
  97
  98             ,@(append-map (lambda (dir)
  99                             `((includedir
 100                                ,(string-append dir "/etc/dbus-1/system.d"))
 101                               (servicedir       ;for '.service' files
 102                                ,(string-append dir "/share/dbus-1/services"))))
 103                           services)))
 104
 105         (mkdir #$output)
 106
 107         ;; Provide /etc/dbus-1/system-services, which is where the setuid
 108         ;; helper looks for system service files.
 109         (symlink #$(system-service-directory services)
 110                  (string-append #$output "/system-services"))
 111
 112         ;; 'system-local.conf' is automatically included by the default
 113         ;; 'system.conf', so this is where we stuff our own things.
 114         (call-with-output-file (string-append #$output "/system-local.conf")
 115           (lambda (port)
 116             (sxml->xml (services->sxml (list #$@services))
 117                        port)))))
 118
 119   (computed-file "dbus-configuration" build))
 120
 121 (define (dbus-etc-files config)
 122   "Return a list of FILES for @var{etc-service-type} to build the
 123 @code{/etc/dbus-1} directory."
 124   (list `("dbus-1" ,(dbus-configuration-directory
 125                      (dbus-configuration-services config)))))
 126
 127 (define %dbus-accounts
 128   ;; Accounts used by the system bus.
 129   (list (user-group (name "messagebus") (system? #t))
 130         (user-account
 131          (name "messagebus")
 132          (group "messagebus")
 133          (system? #t)
 134          (comment "D-Bus system bus user")
 135          (home-directory "/var/run/dbus")
 136          (shell (file-append shadow "/sbin/nologin")))))
 137
 138 (define dbus-setuid-programs
 139   ;; Return the file name of the setuid program that we need.
 140   (match-lambda
 141     (($ <dbus-configuration> dbus services)
 142      (list (file-append dbus "/libexec/dbus-daemon-launch-helper")))))
 143
 144 (define (dbus-activation config)
 145   "Return an activation gexp for D-Bus using @var{config}."
 146   #~(begin
 147       (use-modules (guix build utils))
 148
 149       (mkdir-p "/var/run/dbus")
 150
 151       (let ((user (getpwnam "messagebus")))
 152         (chown "/var/run/dbus"
 153                (passwd:uid user) (passwd:gid user)))
 154
 155       (unless (file-exists? "/etc/machine-id")
 156         (format #t "creating /etc/machine-id...~%")
 157         (let ((prog (string-append #$(dbus-configuration-dbus config)
 158                                    "/bin/dbus-uuidgen")))
 159           ;; XXX: We can't use 'system' because the initrd's
 160           ;; guile system(3) only works when 'sh' is in $PATH.
 161           (let ((pid (primitive-fork)))
 162             (if (zero? pid)
 163                 (call-with-output-file "/etc/machine-id"
 164                   (lambda (port)
 165                     (close-fdes 1)
 166                     (dup2 (port->fdes port) 1)
 167                     (execl prog)))
 168                 (waitpid pid)))))))
 169
 170 (define dbus-shepherd-service
 171   (match-lambda
 172     (($ <dbus-configuration> dbus)
 173      (list (shepherd-service
 174             (documentation "Run the D-Bus system daemon.")
 175             (provision '(dbus-system))
 176             (requirement '(user-processes))
 177             (start #~(make-forkexec-constructor
 178                       (list (string-append #$dbus "/bin/dbus-daemon")
 179                             "--nofork" "--system")
 180                       #:pid-file "/var/run/dbus/pid"))
 181             (stop #~(make-kill-destructor)))))))
 182
 183 (define dbus-root-service-type
 184   (service-type (name 'dbus)
 185                 (extensions
 186                  (list (service-extension shepherd-root-service-type
 187                                           dbus-shepherd-service)
 188                        (service-extension activation-service-type
 189                                           dbus-activation)
 190                        (service-extension etc-service-type
 191                                           dbus-etc-files)
 192                        (service-extension account-service-type
 193                                           (const %dbus-accounts))
 194                        (service-extension setuid-program-service-type
 195                                           dbus-setuid-programs)))
 196
 197                 ;; Extensions consist of lists of packages (representing D-Bus
 198                 ;; services) that we just concatenate.
 199                 (compose concatenate)
 200
 201                 ;; The service's parameters field is extended by augmenting
 202                 ;; its <dbus-configuration> 'services' field.
 203                 (extend (lambda (config services)
 204                           (dbus-configuration
 205                            (inherit config)
 206                            (services
 207                             (append (dbus-configuration-services config)
 208                                     services)))))))
 209
 210 (define* (dbus-service #:key (dbus dbus) (services '()))
 211   "Return a service that runs the \"system bus\", using @var{dbus}, with
 212 support for @var{services}.
 213
 214 @uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
 215 facility.  Its system bus is used to allow system services to communicate and
 216 be notified of system-wide events.
 217
 218 @var{services} must be a list of packages that provide an
 219 @file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
 220 and policy files.  For example, to allow avahi-daemon to use the system bus,
 221 @var{services} must be equal to @code{(list avahi)}."
 222   (service dbus-root-service-type
 223            (dbus-configuration (dbus dbus)
 224                                (services services))))
 225
 226 \f
 227 ;;;
 228 ;;; Polkit privilege management service.
 229 ;;;
 230
 231 (define-record-type* <polkit-configuration>
 232   polkit-configuration make-polkit-configuration
 233   polkit-configuration?
 234   (polkit   polkit-configuration-polkit           ;<package>
 235             (default polkit))
 236   (actions  polkit-configuration-actions          ;list of <package>
 237             (default '())))
 238
 239 (define %polkit-accounts
 240   (list (user-group (name "polkitd") (system? #t))
 241         (user-account
 242          (name "polkitd")
 243          (group "polkitd")
 244          (system? #t)
 245          (comment "Polkit daemon user")
 246          (home-directory "/var/empty")
 247          (shell "/run/current-system/profile/sbin/nologin"))))
 248
 249 (define %polkit-pam-services
 250   (list (unix-pam-service "polkit-1")))
 251
 252 (define (polkit-directory packages)
 253   "Return a directory containing an @file{actions} and possibly a
 254 @file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
 255   (with-imported-modules '((guix build union))
 256     (computed-file "etc-polkit-1"
 257                    #~(begin
 258                        (use-modules (guix build union) (srfi srfi-26))
 259
 260                        (union-build #$output
 261                                     (map (cut string-append <>
 262                                               "/share/polkit-1")
 263                                          (list #$@packages)))))))
 264
 265 (define polkit-etc-files
 266   (match-lambda
 267     (($ <polkit-configuration> polkit packages)
 268      `(("polkit-1" ,(polkit-directory (cons polkit packages)))))))
 269
 270 (define polkit-setuid-programs
 271   (match-lambda
 272     (($ <polkit-configuration> polkit)
 273      (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
 274            (file-append polkit "/bin/pkexec")))))
 275
 276 (define polkit-service-type
 277   (service-type (name 'polkit)
 278                 (extensions
 279                  (list (service-extension account-service-type
 280                                           (const %polkit-accounts))
 281                        (service-extension pam-root-service-type
 282                                           (const %polkit-pam-services))
 283                        (service-extension dbus-root-service-type
 284                                           (compose
 285                                            list
 286                                            polkit-configuration-polkit))
 287                        (service-extension etc-service-type
 288                                           polkit-etc-files)
 289                        (service-extension setuid-program-service-type
 290                                           polkit-setuid-programs)))
 291
 292                 ;; Extensions are lists of packages that provide polkit rules
 293                 ;; or actions under share/polkit-1/{actions,rules.d}.
 294                 (compose concatenate)
 295                 (extend (lambda (config actions)
 296                           (polkit-configuration
 297                            (inherit config)
 298                            (actions
 299                             (append (polkit-configuration-actions config)
 300                                     actions)))))))
 301
 302 (define* (polkit-service #:key (polkit polkit))
 303   "Return a service that runs the
 304 @uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
 305 management service}, which allows system administrators to grant access to
 306 privileged operations in a structured way.  By querying the Polkit service, a
 307 privileged system component can know when it should grant additional
 308 capabilities to ordinary users.  For example, an ordinary user can be granted
 309 the capability to suspend the system if the user is logged in locally."
 310   (service polkit-service-type
 311            (polkit-configuration (polkit polkit))))
 312
 313 ;;; dbus.scm ends here