gnu/services/dbus.scm

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