[shepherd] 03/03: service: Add #:pid-file to 'make-forkexec-constructor'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 710e9b3851de5e1d68c12d6ac1fe2bf8cf53b011
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jan 25 00:02:26 2016 +0100

    service: Add #:pid-file to 'make-forkexec-constructor'.
    
    * modules/shepherd/service.scm (read-pid-file): New procedure.
    (make-forkexec-constructor): Add #:pid-file parameter and honor it.
    * tests/respawn.sh: Change 'test2' to use #:pid-file.  Use 'test -f'
    instead of 'wait_for_file' for $service2_pid.
    * shepherd.texi (Service De- and Constructors): Adjust accordingly.
---
 modules/shepherd/service.scm |   66 +++++++++++++++++++++++++++++++++++-------
 shepherd.texi                |   19 +++++++----
 tests/respawn.sh             |   18 +++++++----
 3 files changed, 79 insertions(+), 24 deletions(-)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index cf72f8b..f84d1dd 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -25,6 +25,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (rnrs io ports)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (shepherd support)
@@ -66,6 +67,7 @@
             make-kill-destructor
             exec-command
             fork+exec-command
+            read-pid-file
             make-system-constructor
             make-system-destructor
             make-init.d-service
@@ -636,6 +638,29 @@ results."
 set when starting a service."
   (environ))
 
+(define* (read-pid-file file #:key (max-delay 5))
+  "Wait for MAX-DELAY seconds for FILE to show up, and read its content as a
+number.  Return #f if FILE does not contain a number; otherwise return the
+number that was read (a PID)."
+  (define start (current-time))
+  (let loop ()
+    (catch 'system-error
+      (lambda ()
+        (string->number
+         (string-trim-both
+          (call-with-input-file file get-string-all))))
+      (lambda args
+        (let ((errno (system-error-errno args)))
+          (if (and (= ENOENT errno)
+                   (< (current-time) (+ start max-delay)))
+              (begin
+                ;; FILE does not exist yet, so wait and try again.
+                ;; XXX: Ideally we would yield to the main event loop
+                ;; and/or use inotify.
+                (sleep 1)
+                (loop))
+              (apply throw args)))))))
+
 (define* (exec-command command
                        #:key
                        (user #f)
@@ -735,27 +760,46 @@ its PID."
             "This 'make-forkexec-constructor' form is deprecated; use
  (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.  If USER and/or GROUP are given, switch to the
-given USER and/or GROUP to run COMMAND."
+     "Return a procedure that forks a child process, closes all file
+descriptors except the standard output and standard error descriptors, sets
+the current directory to @var{directory}, changes the environment to
address@hidden (using the @code{environ} procedure), sets the
+current user to @var{user} and the current group to @var{group} unless they
+are @code{#f}, and executes @var{command} (a list of strings.)  The result of
+the procedure will be the PID of the child process.
+
+When @var{pid-file} is true, it must be the name of a PID file associated with
+the process being launched; the return value is the PID read from that file,
+once that file has been created."
      ((command #:key
                (user #f)
                (group #f)
                (directory (default-service-directory))
-               (environment-variables (default-environment-variables)))
+               (environment-variables (default-environment-variables))
+               (pid-file #f))
       (let ((command (if (string? command)
                          (begin
                            (warn-deprecated-form)
                            (list command))
                          command)))
         (lambda args
-          (fork+exec-command command
-                             #:user user
-                             #:group group
-                             #:directory directory
-                             #:environment-variables environment-variables))))
+          (when pid-file
+            (catch 'system-error
+              (lambda ()
+                (delete-file pid-file))
+              (lambda args
+                (unless (= ENOENT (system-error-errno args))
+                  (apply throw args)))))
+
+          (let ((pid (fork+exec-command command
+                                        #:user user
+                                        #:group group
+                                        #:directory directory
+                                        #:environment-variables
+                                        environment-variables)))
+            (if pid-file
+                (read-pid-file pid-file)
+                pid)))))
      ((program . program-args)
       ;; The old form, documented until 0.1 included.
       (warn-deprecated-form)
diff --git a/shepherd.texi b/shepherd.texi
index ef1d9da..74cf584 100644
--- a/shepherd.texi
+++ b/shepherd.texi
@@ -833,15 +833,20 @@ execution of the @var{command} was successful, @code{#t} 
if not.
 @deffn {procedure} make-forkexec-constructor @var{command} @
   [#:user #f] @
   [#:group #f] @
+  [#:pid-file #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),
-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.
+Return a procedure that forks a child process, closes all file
+descriptors except the standard output and standard error descriptors, sets
+the current directory to @var{directory}, changes the environment to
address@hidden (using the @code{environ} procedure), sets the
+current user to @var{user} and the current group to @var{group} unless they
+are @code{#f}, and executes @var{command} (a list of strings.)  The result of
+the procedure will be the PID of the child process.
+
+When @var{pid-file} is true, it must be the name of a PID file
+associated with the process being launched; the return value is the PID
+read from that file, once that file has been created.
 @end deffn
 
 @deffn {procedure} make-kill-destructor address@hidden
diff --git a/tests/respawn.sh b/tests/respawn.sh
index 057c3ea..32d18db 100644
--- a/tests/respawn.sh
+++ b/tests/respawn.sh
@@ -73,12 +73,15 @@ cat > "$conf"<<EOF
  (make <service>
    #:provides '(test2)
    #:start (make-forkexec-constructor
+            ;; The 'sleep' below is just to make it more likely
+            ;; that synchronization issues in handling #:pid-file
+            ;; would be caught.
            '("$SHELL" "-c"
-             "echo \$\$ > $PWD/$service2_pid ; while true ; do sleep 1 ; 
done"))
+             "sleep 0.7 ; echo \$\$ > $PWD/$service2_pid ; while true ; do 
sleep 1 ; done")
+            #:pid-file "$PWD/$service2_pid")
    #:stop  (make-kill-destructor)
    #:respawn? #t))
 (start 'test1)
-(start 'test2)
 EOF
 
 rm -f "$pid"
@@ -93,13 +96,16 @@ kill -0 $dmd_pid
 test -S "$socket"
 $herd status
 $herd status test1 | grep started
+
+$herd start test2
 $herd status test2 | grep started
 
-# The services are started, but that does not mean that they have
-# written their PID file yet, so use 'wait_for_file' rather than
-# 'test -f'.
+# When 'herd start test2' returns, the PID file must already be created.
+test -f "$service2_pid"
+
+# Conversely, 'test1' may not have written its PID file yet, so use
+# 'wait_for_file' rather than 'test -f'.
 wait_for_file "$service1_pid"
-wait_for_file "$service2_pid"
 
 # Make sure the PIDs are valid.
 kill -0 `cat "$service1_pid"`