gnu/services/dbus.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
   4 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
   5 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (gnu services dbus)
  23   #:use-module (gnu services)
  24   #:use-module (gnu services shepherd)
  25   #:use-module (gnu system setuid)
  26   #:use-module (gnu system shadow)
  27   #:use-module (gnu system pam)
  28   #:use-module ((gnu packages glib) #:select (dbus))
  29   #:use-module (gnu packages polkit)
  30   #:use-module (gnu packages admin)
  31   #:use-module (guix gexp)
  32   #:use-module ((guix packages) #:select (package-name))
  33   #:use-module (guix records)
  34   #:use-module (guix modules)
  35   #:use-module (srfi srfi-1)
  36   #:use-module (ice-9 match)
  37   #:export (dbus-configuration
  38             dbus-configuration?
  39             dbus-root-service-type
  40             dbus-service
  41             wrapped-dbus-service
  42
  43             polkit-service-type
  44             polkit-service))
  45
  46 ;;;
  47 ;;; D-Bus.
  48 ;;;
  49
  50 (define-record-type* <dbus-configuration>
  51   dbus-configuration make-dbus-configuration
  52   dbus-configuration?
  53   (dbus      dbus-configuration-dbus              ;file-like
  54              (default dbus))
  55   (services  dbus-configuration-services          ;list of <package>
  56              (default '()))
  57   (verbose?  dbus-configuration-verbose?          ;boolean
  58              (default #f)))
  59
  60 (define (system-service-directory services)
  61   "Return the system service directory, containing @code{.service} files for
  62 all the services that may be activated by the daemon."
  63   (computed-file "dbus-system-services"
  64                  (with-imported-modules '((guix build utils))
  65                    #~(begin
  66                        (use-modules (guix build utils)
  67                                     (srfi srfi-1))
  68
  69                        (define files
  70                          (append-map (lambda (service)
  71                                        (find-files
  72                                         (string-append
  73                                          service
  74                                          "/share/dbus-1/")
  75                                         "\\.service$"))
  76                                      (list #$@services)))
  77
  78                        (mkdir #$output)
  79                        (for-each (lambda (file)
  80                                    (symlink file
  81                                             (string-append #$output "/"
  82                                                            (basename file))))
  83                                  files)
  84                        #t))))
  85
  86 (define (dbus-configuration-directory services)
  87   "Return a directory contains the @code{system-local.conf} file for DBUS that
  88 includes the @code{etc/dbus-1/system.d} directories of each package listed in
  89 @var{services}."
  90   (define build
  91     #~(begin
  92         (use-modules (sxml simple)
  93                      (srfi srfi-1))
  94
  95         (define-syntax directives
  96           (syntax-rules ()
  97             ;; Expand the given directives (SXML expressions) only if their
  98             ;; key names a file that exists.
  99             ((_ (name directory) rest ...)
 100              (let ((dir directory))
 101                (if (file-exists? dir)
 102                    `((name ,dir)
 103                      ,@(directives rest ...))
 104                    (directives rest ...))))
 105             ((_)
 106              '())))
 107
 108         (define (services->sxml services)
 109           ;; Return the SXML 'includedir' clauses for DIRS.
 110           `(busconfig
 111              ;; Increase this timeout to 300 seconds to work around race-y
 112              ;; failures such as <https://issues.guix.gnu.org/52051> on slow
 113              ;; computers with slow I/O.
 114             (limit (@ (name "auth_timeout")) "300000")
 115             (servicehelper "/run/setuid-programs/dbus-daemon-launch-helper")
 116
 117             ;; First, the '.service' files of services subject to activation.
 118             ;; We use a fixed location under /etc because the setuid helper
 119             ;; looks for them in that location and nowhere else.  See
 120             ;; <https://bugs.freedesktop.org/show_bug.cgi?id=92458>.
 121             (servicedir "/etc/dbus-1/system-services")
 122
 123             ,@(append-map (lambda (dir)
 124                             (directives
 125                              (includedir
 126                               (string-append dir "/etc/dbus-1/system.d"))
 127                              (includedir
 128                               (string-append dir "/share/dbus-1/system.d"))
 129                              (servicedir          ;for '.service' files
 130                               (string-append dir "/share/dbus-1/services"))))
 131                           services)))
 132
 133         (mkdir #$output)
 134
 135         ;; Provide /etc/dbus-1/system-services, which is where the setuid
 136         ;; helper looks for system service files.
 137         (symlink #$(system-service-directory services)
 138                  (string-append #$output "/system-services"))
 139
 140         ;; 'system-local.conf' is automatically included by the default
 141         ;; 'system.conf', so this is where we stuff our own things.
 142         (call-with-output-file (string-append #$output "/system-local.conf")
 143           (lambda (port)
 144             (sxml->xml (services->sxml (list #$@services))
 145                        port)))))
 146
 147   (computed-file "dbus-configuration" build))
 148
 149 (define (dbus-etc-files config)
 150   "Return a list of FILES for @var{etc-service-type} to build the
 151 @code{/etc/dbus-1} directory."
 152   (list `("dbus-1" ,(dbus-configuration-directory
 153                      (dbus-configuration-services config)))))
 154
 155 (define %dbus-accounts
 156   ;; Accounts used by the system bus.
 157   (list (user-group (name "messagebus") (system? #t))
 158         (user-account
 159          (name "messagebus")
 160          (group "messagebus")
 161          (system? #t)
 162          (comment "D-Bus system bus user")
 163          (home-directory "/var/run/dbus")
 164          (shell (file-append shadow "/sbin/nologin")))))
 165
 166 (define dbus-setuid-programs
 167   ;; Return a list of <setuid-program> for the program that we need.
 168   (match-lambda
 169     (($ <dbus-configuration> dbus services)
 170      (list (setuid-program
 171             (program (file-append
 172                       dbus "/libexec/dbus-daemon-launch-helper")))))))
 173
 174 (define (dbus-activation config)
 175   "Return an activation gexp for D-Bus using @var{config}."
 176   (with-imported-modules (source-module-closure
 177                           '((gnu build activation)
 178                             (guix build utils)))
 179     #~(begin
 180         (use-modules (gnu build activation)
 181                      (guix build utils))
 182
 183         (let ((user (getpwnam "messagebus")))
 184           ;; This directory contains the daemon's socket so it must be
 185           ;; world-readable.
 186           (mkdir-p/perms "/var/run/dbus" user #o755))
 187
 188         (unless (file-exists? "/etc/machine-id")
 189           (format #t "creating /etc/machine-id...~%")
 190           (invoke (string-append #$(dbus-configuration-dbus config)
 191                                  "/bin/dbus-uuidgen")
 192                   "--ensure=/etc/machine-id")))))
 193
 194 (define dbus-shepherd-service
 195   (match-lambda
 196     (($ <dbus-configuration> dbus _ verbose?)
 197      (list (shepherd-service
 198             (documentation "Run the D-Bus system daemon.")
 199             (provision '(dbus-system))
 200             (requirement '(user-processes syslogd))
 201             (start #~(make-forkexec-constructor
 202                       (list (string-append #$dbus "/bin/dbus-daemon")
 203                             "--nofork" "--system" "--syslog-only")
 204                       #$@(if verbose?
 205                              ;; Since the verbose output goes to the console,
 206                              ;; not syslog, add a log file to capture it.
 207                              '(#:environment-variables '("DBUS_VERBOSE=1")
 208                                #:log-file "/var/log/dbus-daemon.log")
 209                              '())
 210                       #:pid-file "/var/run/dbus/pid"))
 211             (stop #~(make-kill-destructor)))))))
 212
 213 (define dbus-root-service-type
 214   (service-type (name 'dbus)
 215                 (extensions
 216                  (list (service-extension shepherd-root-service-type
 217                                           dbus-shepherd-service)
 218                        (service-extension activation-service-type
 219                                           dbus-activation)
 220                        (service-extension etc-service-type
 221                                           dbus-etc-files)
 222                        (service-extension account-service-type
 223                                           (const %dbus-accounts))
 224                        (service-extension setuid-program-service-type
 225                                           dbus-setuid-programs)))
 226
 227                 ;; Extensions consist of lists of packages (representing D-Bus
 228                 ;; services) that we just concatenate.
 229                 (compose concatenate)
 230
 231                 ;; The service's parameters field is extended by augmenting
 232                 ;; its <dbus-configuration> 'services' field.
 233                 (extend (lambda (config services)
 234                           (dbus-configuration
 235                            (inherit config)
 236                            (services
 237                             (append (dbus-configuration-services config)
 238                                     services)))))
 239
 240                 (default-value (dbus-configuration))
 241                 (description "Run the system-wide D-Bus inter-process message
 242 bus.  It allows programs and daemons to communicate and is also responsible
 243 for spawning (@dfn{activating}) D-Bus services on demand.")))
 244
 245 (define* (dbus-service #:key (dbus dbus) (services '()) verbose?)
 246   "Return a service that runs the \"system bus\", using @var{dbus}, with
 247 support for @var{services}.  When @var{verbose?} is true, it causes the
 248 @samp{DBUS_VERBOSE} environment variable to be set to @samp{1}; a
 249 verbose-enabled D-Bus package such as @code{dbus-verbose} should be provided
 250 as @var{dbus} in this scenario.
 251
 252 @uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
 253 facility.  Its system bus is used to allow system services to communicate and
 254 be notified of system-wide events.
 255
 256 @var{services} must be a list of packages that provide an
 257 @file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
 258 and policy files.  For example, to allow avahi-daemon to use the system bus,
 259 @var{services} must be equal to @code{(list avahi)}."
 260   (service dbus-root-service-type
 261            (dbus-configuration (dbus dbus)
 262                                (services services)
 263                                (verbose? verbose?))))
 264
 265 (define (wrapped-dbus-service service program variables)
 266   "Return a wrapper for @var{service}, a package containing a D-Bus service,
 267 where @var{program} is wrapped such that @var{variables}, a list of name/value
 268 tuples, are all set as environment variables when the bus daemon launches it."
 269   (define wrapper
 270     (program-file (string-append (package-name service) "-program-wrapper")
 271                   #~(begin
 272                       (use-modules (ice-9 match))
 273
 274                       (for-each (match-lambda
 275                                   ((variable value)
 276                                    (setenv variable value)))
 277                                 '#$variables)
 278
 279                       (apply execl (string-append #$service "/" #$program)
 280                              (string-append #$service "/" #$program)
 281                              (cdr (command-line))))))
 282
 283   (define build
 284     (with-imported-modules '((guix build utils))
 285       #~(begin
 286           (use-modules (guix build utils))
 287
 288           (define service-directory
 289             "/share/dbus-1/system-services")
 290
 291           (mkdir-p (dirname (string-append #$output
 292                                            service-directory)))
 293           (copy-recursively (string-append #$service
 294                                            service-directory)
 295                             (string-append #$output
 296                                            service-directory))
 297           (symlink (string-append #$service "/etc") ;for etc/dbus-1
 298                    (string-append #$output "/etc"))
 299
 300           (for-each (lambda (file)
 301                       (substitute* file
 302                         (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$"
 303                           _ original-program arguments)
 304                          (string-append "Exec=" #$wrapper arguments
 305                                         "\n"))))
 306                     (find-files #$output "\\.service$")))))
 307
 308   (computed-file (string-append (package-name service) "-wrapper")
 309                  build))
 310
 311 \f
 312 ;;;
 313 ;;; Polkit privilege management service.
 314 ;;;
 315
 316 (define-record-type* <polkit-configuration>
 317   polkit-configuration make-polkit-configuration
 318   polkit-configuration?
 319   (polkit   polkit-configuration-polkit           ;file-like
 320             (default %default-polkit))
 321   (actions  polkit-configuration-actions          ;list of file-like
 322             (default '())))
 323
 324 (define %default-polkit
 325   ;; The default polkit package.
 326   (let-system (system target)
 327     ;; Since mozjs depends on Rust, which is currently x86_64-only, use
 328     ;; polkit-duktape on other systems.
 329     (if (string-prefix? "x86_64-" (or target system))
 330         polkit-mozjs
 331         polkit-duktape)))
 332
 333 (define %polkit-accounts
 334   (list (user-group (name "polkitd") (system? #t))
 335         (user-account
 336          (name "polkitd")
 337          (group "polkitd")
 338          (system? #t)
 339          (comment "Polkit daemon user")
 340          (home-directory "/var/empty")
 341          (shell "/run/current-system/profile/sbin/nologin"))))
 342
 343 (define %polkit-pam-services
 344   (list (unix-pam-service "polkit-1")))
 345
 346 (define (polkit-directory packages)
 347   "Return a directory containing an @file{actions} and possibly a
 348 @file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
 349   (with-imported-modules '((guix build union))
 350     (computed-file "etc-polkit-1"
 351                    #~(begin
 352                        (use-modules (guix build union) (srfi srfi-26))
 353
 354                        (union-build #$output
 355                                     (map (cut string-append <>
 356                                               "/share/polkit-1")
 357                                          (list #$@packages)))))))
 358
 359 (define polkit-etc-files
 360   (match-lambda
 361     (($ <polkit-configuration> polkit packages)
 362      `(("polkit-1" ,(polkit-directory (cons polkit packages)))))))
 363
 364 (define polkit-setuid-programs
 365   (match-lambda
 366     (($ <polkit-configuration> polkit)
 367      (map file-like->setuid-program
 368           (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
 369                 (file-append polkit "/bin/pkexec"))))))
 370
 371 (define polkit-service-type
 372   (service-type (name 'polkit)
 373                 (extensions
 374                  (list (service-extension account-service-type
 375                                           (const %polkit-accounts))
 376                        (service-extension pam-root-service-type
 377                                           (const %polkit-pam-services))
 378                        (service-extension dbus-root-service-type
 379                                           (compose
 380                                            list
 381                                            polkit-configuration-polkit))
 382                        (service-extension etc-service-type
 383                                           polkit-etc-files)
 384                        (service-extension setuid-program-service-type
 385                                           polkit-setuid-programs)))
 386
 387                 ;; Extensions are lists of packages that provide polkit rules
 388                 ;; or actions under share/polkit-1/{actions,rules.d}.
 389                 (compose concatenate)
 390                 (extend (lambda (config actions)
 391                           (polkit-configuration
 392                            (inherit config)
 393                            (actions
 394                             (append (polkit-configuration-actions config)
 395                                     actions)))))
 396
 397                 (default-value (polkit-configuration))
 398                 (description
 399                  "Run the
 400 @uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
 401 management service}, which allows system administrators to grant access to
 402 privileged operations in a structured way.  Polkit is a requirement for most
 403 desktop environments, such as GNOME.")))
 404
 405 (define* (polkit-service #:key (polkit polkit))
 406   "Return a service that runs the
 407 @uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
 408 management service}, which allows system administrators to grant access to
 409 privileged operations in a structured way.  By querying the Polkit service, a
 410 privileged system component can know when it should grant additional
 411 capabilities to ordinary users.  For example, an ordinary user can be granted
 412 the capability to suspend the system if the user is logged in locally."
 413   (service polkit-service-type
 414            (polkit-configuration (polkit polkit))))
 415
 416 ;;; dbus.scm ends here