gnu/services/dbus.scm

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