gnu/services/dbus.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 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                 (default-value (dbus-configuration))))
 211
 212 (define* (dbus-service #:key (dbus dbus) (services '()))
 213   "Return a service that runs the \"system bus\", using @var{dbus}, with
 214 support for @var{services}.
 215
 216 @uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
 217 facility.  Its system bus is used to allow system services to communicate and
 218 be notified of system-wide events.
 219
 220 @var{services} must be a list of packages that provide an
 221 @file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
 222 and policy files.  For example, to allow avahi-daemon to use the system bus,
 223 @var{services} must be equal to @code{(list avahi)}."
 224   (service dbus-root-service-type
 225            (dbus-configuration (dbus dbus)
 226                                (services services))))
 227
 228 \f
 229 ;;;
 230 ;;; Polkit privilege management service.
 231 ;;;
 232
 233 (define-record-type* <polkit-configuration>
 234   polkit-configuration make-polkit-configuration
 235   polkit-configuration?
 236   (polkit   polkit-configuration-polkit           ;<package>
 237             (default polkit))
 238   (actions  polkit-configuration-actions          ;list of <package>
 239             (default '())))
 240
 241 (define %polkit-accounts
 242   (list (user-group (name "polkitd") (system? #t))
 243         (user-account
 244          (name "polkitd")
 245          (group "polkitd")
 246          (system? #t)
 247          (comment "Polkit daemon user")
 248          (home-directory "/var/empty")
 249          (shell "/run/current-system/profile/sbin/nologin"))))
 250
 251 (define %polkit-pam-services
 252   (list (unix-pam-service "polkit-1")))
 253
 254 (define (polkit-directory packages)
 255   "Return a directory containing an @file{actions} and possibly a
 256 @file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
 257   (with-imported-modules '((guix build union))
 258     (computed-file "etc-polkit-1"
 259                    #~(begin
 260                        (use-modules (guix build union) (srfi srfi-26))
 261
 262                        (union-build #$output
 263                                     (map (cut string-append <>
 264                                               "/share/polkit-1")
 265                                          (list #$@packages)))))))
 266
 267 (define polkit-etc-files
 268   (match-lambda
 269     (($ <polkit-configuration> polkit packages)
 270      `(("polkit-1" ,(polkit-directory (cons polkit packages)))))))
 271
 272 (define polkit-setuid-programs
 273   (match-lambda
 274     (($ <polkit-configuration> polkit)
 275      (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
 276            (file-append polkit "/bin/pkexec")))))
 277
 278 (define polkit-service-type
 279   (service-type (name 'polkit)
 280                 (extensions
 281                  (list (service-extension account-service-type
 282                                           (const %polkit-accounts))
 283                        (service-extension pam-root-service-type
 284                                           (const %polkit-pam-services))
 285                        (service-extension dbus-root-service-type
 286                                           (compose
 287                                            list
 288                                            polkit-configuration-polkit))
 289                        (service-extension etc-service-type
 290                                           polkit-etc-files)
 291                        (service-extension setuid-program-service-type
 292                                           polkit-setuid-programs)))
 293
 294                 ;; Extensions are lists of packages that provide polkit rules
 295                 ;; or actions under share/polkit-1/{actions,rules.d}.
 296                 (compose concatenate)
 297                 (extend (lambda (config actions)
 298                           (polkit-configuration
 299                            (inherit config)
 300                            (actions
 301                             (append (polkit-configuration-actions config)
 302                                     actions)))))
 303
 304                 (default-value (polkit-configuration))))
 305
 306 (define* (polkit-service #:key (polkit polkit))
 307   "Return a service that runs the
 308 @uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
 309 management service}, which allows system administrators to grant access to
 310 privileged operations in a structured way.  By querying the Polkit service, a
 311 privileged system component can know when it should grant additional
 312 capabilities to ordinary users.  For example, an ordinary user can be granted
 313 the capability to suspend the system if the user is logged in locally."
 314   (service polkit-service-type
 315            (polkit-configuration (polkit polkit))))
 316
 317 ;;; dbus.scm ends here