Merge branch 'dbus-update'

2 files changed, 75 insertions, 80 deletions

diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index e4ecd961c5..9b0d198683 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,7 +21,7 @@
   #:use-module (gnu services)
   #:use-module (gnu services dmd)
   #:use-module (gnu system shadow)
-  #:use-module (gnu packages glib)
+  #:use-module ((gnu packages glib) #:select (dbus/activation))
   #:use-module (gnu packages admin)
   #:use-module (guix gexp)
   #:use-module (guix records)
@@ -37,13 +38,38 @@
   dbus-configuration make-dbus-configuration
   dbus-configuration?
   (dbus      dbus-configuration-dbus              ;<package>
-             (default dbus))
+             (default dbus/activation))
   (services  dbus-configuration-services          ;list of <package>
              (default '())))
 
-(define (dbus-configuration-directory dbus services)
-  "Return a configuration directory for @var{dbus} that includes the
-@code{etc/dbus-1/system.d} directories of each package listed in
+(define (system-service-directory services)
+  "Return the system service directory, containing @code{.service} files for
+all the services that may be activated by the daemon."
+  (computed-file "dbus-system-services"
+                 #~(begin
+                     (use-modules (guix build utils)
+                                  (srfi srfi-1))
+
+                     (define files
+                       (append-map (lambda (service)
+                                     (find-files (string-append
+                                                  service
+                                                  "/share/dbus-1/system-services")
+                                                 "\\.service$"))
+                                   (list #$@services)))
+
+                     (mkdir #$output)
+                     (for-each (lambda (file)
+                                 (symlink file
+                                          (string-append #$output "/"
+                                                         (basename file))))
+                               files)
+                     #t)
+                 #:modules '((guix build utils))))
+
+(define (dbus-configuration-directory services)
+  "Return a directory contains the @code{system-local.conf} file for DBUS that
+includes the @code{etc/dbus-1/system.d} directories of each package listed in
 @var{services}."
   (define build
     #~(begin
@@ -53,24 +79,27 @@
         (define (services->sxml services)
           ;; Return the SXML 'includedir' clauses for DIRS.
           `(busconfig
+            (servicehelper "/run/setuid-programs/dbus-daemon-launch-helper")
+
+            ;; First, the '.service' files of services subject to activation.
+            ;; We use a fixed location under /etc because the setuid helper
+            ;; looks for them in that location and nowhere else.  See
+            ;; <https://bugs.freedesktop.org/show_bug.cgi?id=92458>.
+            (servicedir "/etc/dbus-1/system-services")
+
             ,@(append-map (lambda (dir)
                             `((includedir
                                ,(string-append dir "/etc/dbus-1/system.d"))
-                              (servicedir         ;for '.service' files
-                               ,(string-append dir "/share/dbus-1/services"))
-                              (servicedir       ;likewise, for auto-activation
-                               ,(string-append
-                                 dir
-                                 "/share/dbus-1/system-services"))))
+                              (servicedir       ;for '.service' files
+                               ,(string-append dir "/share/dbus-1/services"))))
                           services)))
 
         (mkdir #$output)
-        (copy-file (string-append #$dbus "/etc/dbus-1/system.conf")
-                   (string-append #$output "/system.conf"))
 
-        ;; The default 'system.conf' has an <includedir> clause for
-        ;; 'system.d', so create it.
-        (mkdir (string-append #$output "/system.d"))
+        ;; Provide /etc/dbus-1/system-services, which is where the setuid
+        ;; helper looks for system service files.
+        (symlink #$(system-service-directory services)
+                 (string-append #$output "/system-services"))
 
         ;; 'system-local.conf' is automatically included by the default
         ;; 'system.conf', so this is where we stuff our own things.
@@ -81,6 +110,12 @@
 
   (computed-file "dbus-configuration" build))
 
+(define (dbus-etc-files config)
+  "Return a list of FILES for @var{etc-service-type} to build the
+@code{/etc/dbus-1} directory."
+  (list `("dbus-1" ,(dbus-configuration-directory
+                     (dbus-configuration-services config)))))
+
 (define %dbus-accounts
   ;; Accounts used by the system bus.
   (list (user-group (name "messagebus") (system? #t))
@@ -92,6 +127,12 @@
          (home-directory "/var/run/dbus")
          (shell #~(string-append #$shadow "/sbin/nologin")))))
 
+(define dbus-setuid-programs
+  ;; Return the file name of the setuid program that we need.
+  (match-lambda
+    (($ <dbus-configuration> dbus services)
+     (list #~(string-append #$dbus "/libexec/dbus-daemon-launch-helper")))))
+
 (define (dbus-activation config)
   "Return an activation gexp for D-Bus using @var{config}."
   #~(begin
@@ -120,18 +161,15 @@
 
 (define dbus-dmd-service
   (match-lambda
-    (($ <dbus-configuration> dbus services)
-     (let ((conf (dbus-configuration-directory dbus services)))
-       (list (dmd-service
-              (documentation "Run the D-Bus system daemon.")
-              (provision '(dbus-system))
-              (requirement '(user-processes))
-              (start #~(make-forkexec-constructor
-                        (list (string-append #$dbus "/bin/dbus-daemon")
-                              "--nofork"
-                              (string-append "--config-file=" #$conf
-                                             "/system.conf"))))
-              (stop #~(make-kill-destructor))))))))
+    (($ <dbus-configuration> dbus)
+     (list (dmd-service
+            (documentation "Run the D-Bus system daemon.")
+            (provision '(dbus-system))
+            (requirement '(user-processes))
+            (start #~(make-forkexec-constructor
+                      (list (string-append #$dbus "/bin/dbus-daemon")
+                            "--nofork" "--system")))
+            (stop #~(make-kill-destructor)))))))
 
 (define dbus-root-service-type
   (service-type (name 'dbus)
@@ -140,14 +178,15 @@
                                           dbus-dmd-service)
                        (service-extension activation-service-type
                                           dbus-activation)
+                       (service-extension etc-service-type
+                                          dbus-etc-files)
                        (service-extension account-service-type
-                                          (const %dbus-accounts))))
+                                          (const %dbus-accounts))
+                       (service-extension setuid-program-service-type
+                                          dbus-setuid-programs)))
 
                 ;; Extensions consist of lists of packages (representing D-Bus
                 ;; services) that we just concatenate.
-                ;;
-                ;; FIXME: We need 'dbus-daemon-launch-helper' to be
-                ;; setuid-root for auto-activation to work.
                 (compose concatenate)
 
                 ;; The service's parameters field is extended by augmenting
@@ -159,7 +198,7 @@
                             (append (dbus-configuration-services config)
                                     services)))))))
 
-(define* (dbus-service #:key (dbus dbus) (services '()))
+(define* (dbus-service #:key (dbus dbus/activation) (services '()))
   "Return a service that runs the \"system bus\", using @var{dbus}, with
 support for @var{services}.
 
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index f283008c4c..166895663f 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -247,17 +247,6 @@ levels, with the given configuration settings.  It implements the
          (home-directory "/var/empty")
          (shell #~(string-append #$shadow "/sbin/nologin")))))
 
-(define (colord-dmd-service colord)
-  "Return a dmd service for COLORD."
-  ;; TODO: Remove when D-Bus activation works.
-  (list (dmd-service
-         (documentation "Run the colord color management service.")
-         (provision '(colord-daemon))
-         (requirement '(dbus-system udev))
-         (start #~(make-forkexec-constructor
-                   (list (string-append #$colord "/libexec/colord"))))
-         (stop #~(make-kill-destructor)))))
-
 (define colord-service-type
   (service-type (name 'colord)
                 (extensions
@@ -265,8 +254,6 @@ levels, with the given configuration settings.  It implements the
                                           (const %colord-accounts))
                        (service-extension activation-service-type
                                           (const %colord-activation))
-                       (service-extension dmd-root-service-type
-                                          colord-dmd-service)
 
                        ;; Colord is a D-Bus service that dbus-daemon can
                        ;; activate.
@@ -345,23 +332,6 @@ users are allowed."
                               "GEOCLUE_CONFIG_FILE"
                               (geoclue-configuration-file config))))
 
-(define (geoclue-dmd-service config)
-  "Return a GeoClue dmd service for CONFIG."
-  ;; TODO: Remove when D-Bus activation works.
-  (let ((geoclue (geoclue-configuration-geoclue config))
-        (config  (geoclue-configuration-file config)))
-    (list (dmd-service
-           (documentation "Run the GeoClue location service.")
-           (provision '(geoclue-daemon))
-           (requirement '(dbus-system))
-
-           (start #~(make-forkexec-constructor
-                     (list (string-append #$geoclue "/libexec/geoclue"))
-                     #:user "geoclue"
-                     #:environment-variables
-                     (list (string-append "GEOCLUE_CONFIG_FILE=" #$config))))
-           (stop #~(make-kill-destructor))))))
-
 (define %geoclue-accounts
   (list (user-group (name "geoclue") (system? #t))
         (user-account
@@ -377,8 +347,6 @@ users are allowed."
                 (extensions
                  (list (service-extension dbus-root-service-type
                                           geoclue-dbus-service)
-                       (service-extension dmd-root-service-type
-                                          geoclue-dmd-service)
                        (service-extension account-service-type
                                           (const %geoclue-accounts))))))
 
@@ -428,18 +396,6 @@ site} for more information."
 (define %polkit-pam-services
   (list (unix-pam-service "polkitd")))
 
-(define (polkit-dmd-service polkit)
-  "Return the <dmd-service> for POLKIT."
-  ;; TODO: Remove when D-Bus activation works.
-  (list (dmd-service
-         (documentation "Run the polkit privilege management service.")
-         (provision '(polkit-daemon))
-         (requirement '(dbus-system))
-
-         (start #~(make-forkexec-constructor
-                   (list (string-append #$polkit "/lib/polkit-1/polkitd"))))
-         (stop #~(make-kill-destructor)))))
-
 (define polkit-service-type
   ;; TODO: Make it extensible so it can collect policy files from other
   ;; services.
@@ -450,9 +406,7 @@ site} for more information."
                        (service-extension pam-root-service-type
                                           (const %polkit-pam-services))
                        (service-extension dbus-root-service-type
-                                          list)
-                       (service-extension dmd-root-service-type
-                                          polkit-dmd-service)))))
+                                          list)))))
 
 (define* (polkit-service #:key (polkit polkit))
   "Return a service that runs the @command{polkit} privilege management
@@ -603,6 +557,8 @@ the system if the user is logged in locally."
 
 (define (elogind-dmd-service config)
   "Return a dmd service for elogind, using @var{config}."
+  ;; TODO: We could probably rely on service activation but the '.service'
+  ;; file currently contains an erroneous 'Exec' line.
   (let ((config-file (elogind-configuration-file config))
         (elogind     (elogind-package config)))
     (list (dmd-service