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