03/04: services: dbus: Support service activation.

[Ludovic Courtès]

civodul pushed a commit to branch dbus-update
in repository guix.

commit cde0402169cd93497084664c8d8d399808a1ea82
Author: Ludovic Courtès <address@hidden>
Date:   Thu Oct 22 00:35:10 2015 +0200

    services: dbus: Support service activation.
    
    * gnu/services/dbus.scm (system-service-directory): New procedure.
      (dbus-configuration-directory)[services->sxml]: Add
      /etc/dbus-1/system-services <servicedir> tag, and remove the
      per-service "/share/dbus-1/system-services" tag.
      Symlink OUTPUT/system-services.
      (dbus-setuid-programs): New procedure.
      (dbus-root-service-type): Extend SETUID-PROGRAM-SERVICE-TYPE.
      (dbus-service): Default to DBUS/ACTIVATION.
---
 gnu/services/dbus.scm |   66 +++++++++++++++++++++++++++++++++++++++---------
 1 files changed, 53 insertions(+), 13 deletions(-)

diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index 1d504a8..9b0d198 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -21,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)
@@ -38,10 +38,35 @@
   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 (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 address@hidden)))
+
+                     (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
@@ -54,18 +79,28 @@ includes the @code{etc/dbus-1/system.d} directories of each 
package listed in
         (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)
+
+        ;; 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.
         (call-with-output-file (string-append #$output "/system-local.conf")
@@ -92,6 +127,12 @@ includes the @code{etc/dbus-1/system.d} directories of each 
package listed in
          (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
@@ -140,13 +181,12 @@ includes the @code{etc/dbus-1/system.d} directories of 
each package listed in
                        (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
@@ -158,7 +198,7 @@ includes the @code{etc/dbus-1/system.d} directories of each 
package listed in
                             (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}.