[bug#62726] [PATCH v2] services: Activate `setuid-program-service-type' in shepherd.

[Brian Cully]

Activate using a one-shot Shepherd service on boot, rather than attaching to
ACTIVATION-SERVICE-TYPE to populate `/run/setuid-programs'.

In order to prevent a dependency cycle between (gnu services) and (gnu
services shepherd), introduce a new module (gnu services setuid) and deprecate
the import of `setuid-program-service-type' from (gnu services).

Add the new SETUID-PROGRAMS Shepherd service to the extant Shepherd services
which need it, as well as USER-PROCESSES as a catch for things started later.

* gnu/local.mk (GNU_SYSTEM_MODULES): add setuid.scm.
* gnu/services.scm (setuid-program-service-type): removed.
* gnu/services/setuid.scm: new module.
* gnu/services/dbus.scm (gnu): import (gnu services setuid).
(dbus-shepherd-service): require SETUID-PROGRAMS.
* gnu/services/desktop.scm (gnu): import (gnu services setuid).
* gnu/services/docker.scm (gnu): import (gnu services setuid).
* gnu/services/mail.scm (gnu): import (gnu services setuid).
(<opensmtpd-configuration>): require SETUID-PROGRAMS.
* gnu/services/xorg.scm (gnu): import (gnu services setuid).
* gnu/system.scm (gnu): import (gnu services setuid).
* gnu/system/pam.scm (gnu): import (gnu services setuid).
(pam-root-service): require SETUID-PROGRAMS by default.
---
 gnu/local.mk             |  1 +
 gnu/services.scm         | 38 ---------------------------
 gnu/services/dbus.scm    |  3 ++-
 gnu/services/desktop.scm |  1 +
 gnu/services/docker.scm  |  1 +
 gnu/services/mail.scm    |  3 ++-
 gnu/services/setuid.scm  | 57 ++++++++++++++++++++++++++++++++++++++++
 gnu/services/xorg.scm    |  1 +
 gnu/system.scm           |  1 +
 gnu/system/pam.scm       |  5 +++-
 10 files changed, 70 insertions(+), 41 deletions(-)
 create mode 100644 gnu/services/setuid.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 9adf593318..6f9013056c 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -708,6 +708,7 @@ GNU_SYSTEM_MODULES =                                \
   %D%/services/rsync.scm                       \
   %D%/services/samba.scm                       \
   %D%/services/sddm.scm                                \
+  %D%/services/setuid.scm                      \
   %D%/services/spice.scm                               \
   %D%/services/ssh.scm                         \
   %D%/services/syncthing.scm                   \
diff --git a/gnu/services.scm b/gnu/services.scm
index a990d297c9..a17f7dcee1 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -44,7 +44,6 @@ (define-module (gnu services)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages hurd)
-  #:use-module (gnu system setuid)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
@@ -111,7 +110,6 @@ (define-module (gnu services)
             extra-special-file
             etc-service-type
             etc-directory
-            setuid-program-service-type
             profile-service-type
             firmware-service-type
             gc-root-service-type
@@ -828,42 +826,6 @@ (define-deprecated (etc-service files)
 FILES must be a list of name/file-like object pairs."
   (service etc-service-type files))
 
-(define (setuid-program->activation-gexp programs)
-  "Return an activation gexp for setuid-program from PROGRAMS."
-  (let ((programs (map (lambda (program)
-                         ;; FIXME This is really ugly, I didn't managed to use
-                         ;; "inherit"
-                         (let ((program-name (setuid-program-program program))
-                               (setuid?      (setuid-program-setuid? program))
-                               (setgid?      (setuid-program-setgid? program))
-                               (user         (setuid-program-user program))
-                               (group        (setuid-program-group program)) )
-                           #~(setuid-program
-                              (setuid? #$setuid?)
-                              (setgid? #$setgid?)
-                              (user    #$user)
-                              (group   #$group)
-                              (program #$program-name))))
-                       programs)))
-    (with-imported-modules (source-module-closure
-                            '((gnu system setuid)))
-      #~(begin
-          (use-modules (gnu system setuid))
-
-          (activate-setuid-programs (list #$@programs))))))
-
-(define setuid-program-service-type
-  (service-type (name 'setuid-program)
-                (extensions
-                 (list (service-extension activation-service-type
-                                          setuid-program->activation-gexp)))
-                (compose concatenate)
-                (extend (lambda (config extensions)
-                          (append config extensions)))
-                (description
-                 "Populate @file{/run/setuid-programs} with the specified
-executables, making them setuid and/or setgid.")))
-
 (define (packages->profile-entry packages)
   "Return a system entry for the profile containing PACKAGES."
   ;; XXX: 'mlet' is needed here for one reason: to get the proper
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index 5a0c634393..7f0deaa037 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -21,6 +21,7 @@
 
 (define-module (gnu services dbus)
   #:use-module (gnu services)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
@@ -200,7 +201,7 @@ (define dbus-shepherd-service
      (list (shepherd-service
             (documentation "Run the D-Bus system daemon.")
             (provision '(dbus-system))
-            (requirement '(user-processes syslogd))
+            (requirement '(user-processes syslogd setuid-programs))
             (start #~(make-forkexec-constructor
                       (list (string-append #$dbus "/bin/dbus-daemon")
                             "--nofork" "--system" "--syslog-only")
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index a63748b652..f7a601ed47 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -33,6 +33,7 @@
 
 (define-module (gnu services desktop)
   #:use-module (gnu services)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 741bab5a8c..32ed9739bf 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -26,6 +26,7 @@ (define-module (gnu services docker)
   #:use-module (gnu services configuration)
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index 12dcc8e71d..3b001e091a 100644
--- a/gnu/services/mail.scm
+++ b/gnu/services/mail.scm
@@ -27,6 +27,7 @@ (define-module (gnu services mail)
   #:use-module (gnu services)
   #:use-module (gnu services base)
   #:use-module (gnu services configuration)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system pam)
   #:use-module (gnu system shadow)
@@ -1655,7 +1656,7 @@ (define-record-type* <opensmtpd-configuration>
   (package     opensmtpd-configuration-package
                (default opensmtpd))
   (shepherd-requirement opensmtpd-configuration-shepherd-requirement
-                        (default '())) ; list of symbols
+                        (default '(setuid-programs))) ; list of symbols
   (config-file opensmtpd-configuration-config-file
                (default %default-opensmtpd-config-file))
   (setgid-commands? opensmtpd-setgid-commands? (default #t)))
diff --git a/gnu/services/setuid.scm b/gnu/services/setuid.scm
new file mode 100644
index 0000000000..00319aabdc
--- /dev/null
+++ b/gnu/services/setuid.scm
@@ -0,0 +1,57 @@
+(define-module (gnu services setuid)
+  #:use-module (gnu services)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system setuid)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (srfi srfi-1)
+  #:export (setuid-program-service-type))
+
+(define (setuid-programs->shepherd-service programs)
+  (let ((programs (map (lambda (program)
+                         ;; FIXME This is really ugly, I didn't managed to use
+                         ;; "inherit"
+                         (let ((program-name (setuid-program-program program))
+                               (setuid?      (setuid-program-setuid? program))
+                               (setgid?      (setuid-program-setgid? program))
+                               (user         (setuid-program-user program))
+                               (group        (setuid-program-group program)) )
+                           #~(setuid-program
+                              (setuid? #$setuid?)
+                              (setgid? #$setgid?)
+                              (user    #$user)
+                              (group   #$group)
+                              (program #$program-name))))
+                       programs)))
+    (with-imported-modules (source-module-closure
+                            '((gnu system setuid)
+                              (gnu build activation)))
+      (list (shepherd-service
+             (documentation "Populate @file{/run/setuid-programs}.")
+             (provision '(setuid-programs))
+             ;; TODO: actually need to require account service. maybe 
user-homes
+             ;; as a proxy?
+             (requirement '(file-systems))
+             (one-shot? #t)
+             (modules '((gnu system setuid)
+                        (gnu build activation)))
+             (start #~(lambda ()
+                        (activate-setuid-programs (list #$@programs))
+                        #t)))))))
+
+(define setuid-program-service-type
+  (service-type (name 'setuid-program)
+                (extensions
+                 (list
+                  (service-extension shepherd-root-service-type
+                                     setuid-programs->shepherd-service)
+                  ;; Ensure that setuid programs are set up by the time they
+                  ;; might be needed by user-configured processes and daemons.
+                  (service-extension user-processes-service-type
+                                     (const '(setuid-programs)))))
+                (compose concatenate)
+                (extend append)
+                (default-value '())
+                (description
+                 "Populate @file{/run/setuid-programs} with the specified
+executables, making them setuid and/or setgid.")))
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index f8cf9f25b6..efcaa52754 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -35,6 +35,7 @@ (define-module (gnu services xorg)
   #:use-module (gnu artwork)
   #:use-module (gnu services)
   #:use-module (gnu services configuration)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system pam)
   #:use-module (gnu system setuid)
diff --git a/gnu/system.scm b/gnu/system.scm
index 354f58f55b..5f834dd8b6 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -67,6 +67,7 @@ (define-module (gnu system)
   #:use-module (gnu packages text-editors)
   #:use-module (gnu packages wget)
   #:use-module (gnu services)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services base)
   #:use-module (gnu bootloader)
diff --git a/gnu/system/pam.scm b/gnu/system/pam.scm
index a035a92e25..4c62e130de 100644
--- a/gnu/system/pam.scm
+++ b/gnu/system/pam.scm
@@ -24,6 +24,7 @@ (define-module (gnu system pam)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (gnu services)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system setuid)
   #:use-module (ice-9 match)
@@ -443,7 +444,9 @@ (define pam-root-service-type
 program may authenticate users or what it should do when opening a new
 session.")))
 
-(define* (pam-root-service base #:key (transformers '()) 
(shepherd-requirements '()))
+(define* (pam-root-service base
+                           #:key (transformers '())
+                           (shepherd-requirements '(setuid-programs)))
   "The \"root\" PAM service, which collects <pam-service> instance and turns
 them into a /etc/pam.d directory, including the <pam-service> listed in BASE.
 TRANSFORM is a procedure that takes a <pam-service> and returns a

base-commit: 940665301de4effd065d24c167f619286f2adf4c
-- 
2.40.1