[dmd] 01/02: Add ability to set user and group before exec'ing a command

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository dmd.

commit d1d0ff30b3ed2b86b0a3c9bc048d2a855f8e31e6
Author: Andy Wingo <address@hidden>
Date:   Sat Aug 15 20:10:20 2015 +0200

    Add ability to set user and group before exec'ing a command
    
    * dmd.texi (Service De- and Constructors): Document #:user and #:group
      options.
    * modules/dmd/service.scm (exec-command, fork+exec-command):
      (make-forkexec-constructor): Add #:user and #:group keyword arguments.
    
    Signed-off-by: Ludovic Courtès <address@hidden>
---
 dmd.texi                |   24 +++++++++++++++++----
 modules/dmd/service.scm |   50 +++++++++++++++++++++++++++++++++++++++++-----
 2 files changed, 63 insertions(+), 11 deletions(-)

diff --git a/dmd.texi b/dmd.texi
index 206f0a2..97ed341 100644
--- a/dmd.texi
+++ b/dmd.texi
@@ -807,14 +807,17 @@ execution of the @var{command} was successful, @code{#t} 
if not.
 @end deffn
 
 @deffn {procedure} make-forkexec-constructor @var{command} @
+  [#:user #f] @
+  [#:group #f] @
   [#:directory (default-service-directory)] @
   [#:environment-variables (default-environment-variables)]
 Return a procedure that forks a child process, close all file
 descriptors except the standard output and standard error descriptors,
 sets the current directory to @var{directory}, changes the environment
-to @var{environment-variables} (using the @code{environ} procedure), and
-executes @var{command} (a list of strings.)  Return the PID of the child
-process.
+to @var{environment-variables} (using the @code{environ} procedure),
+sets the current user to @var{user} and the current group to
address@hidden, and executes @var{command} (a list of strings.)  The
+result of the procedure will be the PID of the child process.
 @end deffn
 
 @deffn {procedure} make-kill-destructor address@hidden
@@ -830,9 +833,13 @@ The @code{make-forkexec-constructor} procedure builds upon 
the following
 procedures.
 
 @deffn {procedure} exec-command @var{command} @
+  [#:user #f] @
+  [#:group #f] @
   [#:directory (default-service-directory)] @
   [#:environment-variables (default-environment-variables)]
 @deffnx {procedure} fork+exec-command @var{command} @
+  [#:user #f] @
+  [#:group #f] @
   [#:directory (default-service-directory)] @
   [#:environment-variables (default-environment-variables)]
 Run @var{command} as the current process from @var{directory}, and with
@@ -841,8 +848,15 @@ File descriptors 1 and 2 are kept as is, whereas file 
descriptor 0
 (standard input) points to @file{/dev/null}; all other file descriptors
 are closed prior to yielding control to @var{command}.
 
address@hidden does the same, but in a separate process whose
-PID it returns.
+By default, @var{command} is run as the current user.  If the
address@hidden keyword argument is present and not false, change to
address@hidden immediately before invoking @var{command}.  @var{user} may
+be a string, indicating a user name, or a number, indicating a user
+ID.  Likewise, @var{command} will be run under the current group,
+unless the @var{group} keyword argument is present and not false.
+
address@hidden does the same as @code{exec-command}, but in
+a separate process whose PID it returns.
 @end deffn
 
 @c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
diff --git a/modules/dmd/service.scm b/modules/dmd/service.scm
index dd5afe3..67156dd 100644
--- a/modules/dmd/service.scm
+++ b/modules/dmd/service.scm
@@ -575,13 +575,22 @@ set when starting a service."
 
 (define* (exec-command command
                        #:key
+                       (user #f)
+                       (group #f)
                        (directory (default-service-directory))
                        (environment-variables (default-environment-variables)))
   "Run COMMAND as the current process from DIRECTORY, and with
 ENVIRONMENT-VARIABLES (a list of strings like \"PATH=/bin\".)  File
-descriptors 1 and 2 are kept as is, whereas file descriptor 0 (standard
-input) points to /dev/null; all other file descriptors are closed prior to
-yielding control to COMMAND."
+descriptors 1 and 2 are kept as is, whereas file descriptor
+0 (standard input) points to /dev/null; all other file descriptors are
+closed prior to yielding control to COMMAND.
+
+By default, COMMAND is run as the current user.  If the USER keyword
+argument is present and not false, change to USER immediately before
+invoking COMMAND.  USER may be a string, indicating a user name, or a
+number, indicating a user ID.  Likewise, COMMAND will be run under the
+current group, unless the GROUP keyword argument is present and not
+false."
   (match command
     ((program args ...)
      ;; Become the leader of a new session and session group.
@@ -604,6 +613,26 @@ yielding control to COMMAND."
            (catch-system-error (close-fdes i))
            (loop (+ i 1)))))
 
+     (when user
+       (catch #t
+         (lambda ()
+           (setuid (passwd:uid (getpw user))))
+         (lambda (key . args)
+           (format (current-error-port)
+                   "failed to change to user ~s:~%" user)
+           (print-exception (current-error-port) #f key args)
+           (primitive-exit 1))))
+
+     (when group
+       (catch #t
+         (lambda ()
+           (setgid (group:gid (getgr group))))
+         (lambda (key . args)
+           (format (current-error-port)
+                   "failed to change to group ~s:~%" group)
+           (print-exception (current-error-port) #f key args)
+           (primitive-exit 1))))
+
      (catch 'system-error
        (lambda ()
          (apply execlp program program args))
@@ -615,6 +644,8 @@ yielding control to COMMAND."
 
 (define* (fork+exec-command command
                             #:key
+                            (user #f)
+                            (group #f)
                             (directory (default-service-directory))
                             (environment-variables
                              (default-environment-variables)))
@@ -623,6 +654,8 @@ its PID."
   (let ((pid (primitive-fork)))
     (if (zero? pid)
         (exec-command command
+                      #:user user
+                      #:group group
                       #:directory directory
                       #:environment-variables environment-variables)
         pid)))
@@ -636,10 +669,13 @@ its PID."
  (make-forkexec-constructor '(\"PROGRAM\" \"ARGS\"...)."))))
     (case-lambda*
      "Produce a constructor that execs COMMAND, a program name/argument list,
-in a child process and returns its PID.  COMMAND is started with DIRECTORY as
-its current directory, and ENVIRONMENT-VARIABLES as its environment
-variables."
+in a child process and returns its PID.  COMMAND is started with
+DIRECTORY as its current directory, and ENVIRONMENT-VARIABLES as its
+environment variables.  If USER and/or GROUP are given, switch to the
+given USER and/or GROUP to run COMMAND."
      ((command #:key
+               (user #f)
+               (group #f)
                (directory (default-service-directory))
                (environment-variables (default-environment-variables)))
       (let ((command (if (string? command)
@@ -649,6 +685,8 @@ variables."
                          command)))
         (lambda args
           (fork+exec-command command
+                             #:user user
+                             #:group group
                              #:directory directory
                              #:environment-variables environment-variables))))
      ((program . program-args)