[shepherd] 01/02: Use 'with-directory-excursion' for user-supplied directories.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit a464e8b774174cdb594732b93358098305972bc1
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jan 25 23:06:20 2016 +0100

    Use 'with-directory-excursion' for user-supplied directories.
    
    Before that the directory supplied in the command would change that
    current working directory of shepherd, and it would not be changed
    back.
    
    * modules/shepherd/support.scm (with-directory-excursion): New macro.
    * modules/shepherd.scm (process-command): Remove 'chdir' call.  Use
    'with-directory-excursion' instead.
    * tests/basic.sh: Test 'herd load root some-conf.scm'.
---
 modules/shepherd.scm         |   16 ++++++++--------
 modules/shepherd/support.scm |   12 ++++++++++++
 tests/basic.sh               |   26 ++++++++++++++++++++++++++
 3 files changed, 46 insertions(+), 8 deletions(-)

diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 5e26b4f..d258e7f 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -232,7 +232,6 @@
 <shepherd-command> object.  Send the reply to PORT."
   (match command
     (($ <shepherd-command> the-action service-symbol (args ...) dir)
-     (chdir dir)
 
      ;; We have to catch `quit' so that we can send the terminator
      ;; line to herd before we actually quit.
@@ -254,14 +253,15 @@
                                    port)))
 
              (define result
-               (case the-action
-                 ((start) (apply start service-symbol args))
-                 ((stop) (apply stop service-symbol args))
-                 ((enforce) (apply enforce service-symbol args))
+               (with-directory-excursion dir
+                 (case the-action
+                   ((start) (apply start service-symbol args))
+                   ((stop) (apply stop service-symbol args))
+                   ((enforce) (apply enforce service-symbol args))
 
-                 ;; Actions which have the semantics of `action' are
-                 ;; handled there.
-                 (else (apply action service-symbol the-action args))))
+                   ;; Actions which have the semantics of `action' are
+                   ;; handled there.
+                   (else (apply action service-symbol the-action args)))))
 
              (write-reply (command-reply command result #f (get-messages))
                           port))))
diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index 9bfb050..64cd313 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -32,6 +32,7 @@
             EINTR-safe
             with-atomic-file-output
             mkdir-p
+            with-directory-excursion
 
             l10n
             local-output
@@ -175,6 +176,17 @@ output port, and PROC's result is returned."
                  (apply throw args))))))
       (() #t))))
 
+(define-syntax-rule (with-directory-excursion dir body ...) ;copied from Guix
+  "Run BODY with DIR as the process's current directory."
+  (let ((init (getcwd)))
+   (dynamic-wind
+     (lambda ()
+       (chdir dir))
+     (lambda ()
+       body ...)
+     (lambda ()
+       (chdir init)))))
+
 
 
 ;; Localized version of STR.
diff --git a/tests/basic.sh b/tests/basic.sh
index a20e9dc..b1603c6 100644
--- a/tests/basic.sh
+++ b/tests/basic.sh
@@ -120,6 +120,32 @@ $herd status | grep "Stopped: (test-2)"
 $herd reload root "$conf"
 test "`$herd status`" == "$pristine_status"
 
+# Dynamically loading code.
+
+mkdir -p "$confdir"
+cat > "$confdir/some-conf.scm" <<EOF
+(register-services
+ (make <service>
+   #:provides '(test-loaded)
+   #:start (const 42)
+   #:stop (const #f)))
+EOF
+
+if $herd status test-loaded
+then false; else true; fi
+
+# Pass a relative file name and makes sure it's properly resolved.
+(cd "$confdir" && herd -s "../$socket" load root "some-conf.scm")
+rm "$confdir/some-conf.scm"
+
+# The new service should be loaded now.
+$herd status test-loaded
+$herd status test-loaded | grep stopped
+
+$herd start test-loaded
+$herd status test-loaded | grep -i 'running.*42'
+$herd stop test-loaded
+
 # Unload everything and make sure only 'root' is left.
 $herd unload root all
 $herd status | grep "Stopped: ()"