[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[shepherd] 01/02: Use 'with-directory-excursion' for user-supplied direc
From: |
Ludovic Courtès |
Subject: |
[shepherd] 01/02: Use 'with-directory-excursion' for user-supplied directories. |
Date: |
Mon, 25 Jan 2016 22:43:07 +0000 |
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: ()"