[shepherd] 01/02: services: Add 'eval' action to 'root'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit fe6033d2ebb0ffea2a3c5e7299e936757588bb5b
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jan 27 21:43:14 2016 +0100

    services: Add 'eval' action to 'root'.
    
    * modules/shepherd/support.scm (eval-in-user-module): New procedure.
    * modules/shepherd/service.scm (root-service): Add 'eval' action.
    * tests/basic.sh: Add tests.
    * modules/shepherd/scripts/herd.scm (run-command): Add special case for
    'eval'.
    * shepherd.texi (The root and unknown services): Document it.
    * NEWS: Mention it.
---
 NEWS                              |    1 +
 modules/shepherd/scripts/herd.scm |    5 +++++
 modules/shepherd/service.scm      |   14 +++++++++++++-
 modules/shepherd/support.scm      |    8 ++++++++
 shepherd.texi                     |    4 ++++
 tests/basic.sh                    |   14 +++++++++++++-
 6 files changed, 44 insertions(+), 2 deletions(-)

diff --git a/NEWS b/NEWS
index 5971016..bcfd3cc 100644
--- a/NEWS
+++ b/NEWS
@@ -42,6 +42,7 @@ ctrl-alt-del is pressed (see ctrlaltdel(8)).
 
 ** ‘halt’ and ‘reboot’ connect to the system socket unconditionally
 ** ‘herd’ uses a non-zero exit code upon errors
+** The ‘root’ service has a new ‘eval’ action
 ** Basic man pages are now provided
 ** ‘make-forkexec-constructor’ has new #:group and #:user parameters
 ** ‘make-forkexec-constructor’ has a new #:pid-file parameter
diff --git a/modules/shepherd/scripts/herd.scm 
b/modules/shepherd/scripts/herd.scm
index 98e2c7f..e87fd03 100644
--- a/modules/shepherd/scripts/herd.scm
+++ b/modules/shepherd/scripts/herd.scm
@@ -117,6 +117,11 @@ the daemon via SOCKET-FILE."
              ((help-text)
               (display (gettext help-text))
               (newline))))
+          (('eval (or 'root 'shepherd))
+           (match result
+             ((value)
+              (write value)
+              (newline))))
           (('status _)
            ;; We get a list of statuses, in case several services have the
            ;; same name.
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index a7a0daa..6c50273 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -29,6 +29,7 @@
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
+  #:autoload   (ice-9 pretty-print) (truncated-print)
   #:use-module (shepherd support)
   #:use-module (shepherd comm)
   #:use-module (shepherd config)
@@ -1163,12 +1164,23 @@ Clients such as 'herd' can read it and format it in a 
human-readable way."
           (lambda (key)
             (local-output "Shutting down...")
             (power-off)))))
-     ;; Load a configuration file.
+     ;; Evaluate arbitrary code.
      (load
       "Load the Scheme code from FILE into shepherd.  This is potentially
 dangerous.  You have been warned."
       (lambda (running file-name)
         (load-config file-name)))
+     (eval
+      "Evaluate the given Scheme expression into the shepherd.  This is
+potentially dangerous, be careful."
+      (lambda (running str)
+        (let ((exp (call-with-input-string str read)))
+          (local-output "Evaluating user expression ~a."
+                        (call-with-output-string
+                          (lambda (port)
+                            (truncated-print exp port #:width 50))))
+          (eval-in-user-module exp))))
+
      ;; Unload a service
      (unload
       "Unload the service identified by SERVICE-NAME or all services
diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index ba575d3..9bc5f5d 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -50,6 +50,7 @@
             default-persistency-state-file
 
             load-in-user-module
+            eval-in-user-module
 
             persistency
             persistency-state-file
@@ -333,6 +334,13 @@ which has essential bindings pulled in."
        (set-current-module user-module)
        (primitive-load file)))))
 
+(define (eval-in-user-module exp)
+  "Eval EXP in a fresh user module that has essential bindings pulled in."
+  (let ((user-module (make-user-module)))
+    (save-module-excursion
+     (lambda ()
+       (eval exp user-module)))))
+
 (define* (verify-dir dir #:key (secure? #t))
   "Check if the directory DIR exists and create it if it is the default
 directory, but does not exist.  If SECURE? is false, permissions of the
diff --git a/shepherd.texi b/shepherd.texi
index 5dc5f9c..5203af1 100644
--- a/shepherd.texi
+++ b/shepherd.texi
@@ -946,6 +946,10 @@ Evaluate the Scheme code in @var{file} in a fresh module 
that uses the
 @code{(oop goops)} and @code{(shepherd services)} modules---as with the
 @code{--config} option of @command{shepherd} (@pxref{Invoking shepherd}).
 
address@hidden eval @var{exp}
+Likewise, evaluate Scheme expression @var{exp} in a fresh module with
+all the necessary bindings.
+
 @item unload @var{service-name}
 Attempt to remove the service identified by @var{service-name}.
 @command{shepherd} will first stop the service, if necessary, and then
diff --git a/tests/basic.sh b/tests/basic.sh
index ca49109..89f09c3 100644
--- a/tests/basic.sh
+++ b/tests/basic.sh
@@ -30,7 +30,7 @@ pid="t-pid-$$"
 
 herd="herd -s $socket"
 
-trap "rm -f $socket $conf $stamp $log;
+trap "cat $log || true; rm -f $socket $conf $stamp $log;
       test -f $pid && kill \`cat $pid\` || true; rm -f $pid" EXIT
 
 cat > "$conf"<<EOF
@@ -162,6 +162,18 @@ $herd start test-loaded
 $herd status test-loaded | grep -i "running.*#<unspecified>"
 $herd stop test-loaded
 
+# Deregister 'test-loaded' via 'eval'.
+$herd eval root "(action root-service 'unload \"test-loaded\")"
+if $herd status test-loaded
+then false; else true; fi
+
+# Evaluate silly code, make sure nothing breaks.
+if $herd eval root '(/ 0 0)'
+then false; else true; fi
+
+if $herd eval root '(no closing paren'
+then false; else true; fi
+
 # Unload everything and make sure only 'root' is left.
 $herd unload root all
 $herd status | grep "Stopped: ()"