[shepherd] 05/05: Add '&action-runtime-error'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 852341ed0c08941cbdd022135f8bef7be2d7ec54
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jan 20 22:13:25 2016 +0100

    Add '&action-runtime-error'.
    
    * modules/shepherd/service.scm (&action-runtime-error): New error
    condition type.
    (report-exception): New procedure.
    (condition->sexp): Handle it.
    (start): Use 'report-exception' instead of 'caught-error'.
    (action): Remove use of 'can-apply?'.  Use 'report-exception' instead of
    'caught-error'.
    (load-config): Remove 'catch'.
    * modules/shepherd/support.scm (can-apply?): Remove.
    * modules/herd.scm (run-command): Handle 'action-exception' errors.
    * tests/basic.sh: Test the exit code of 'herd' for wrong-arg-num and
    system-error exceptions.
---
 modules/herd.scm             |    7 ++++++
 modules/shepherd/service.scm |   44 +++++++++++++++++++++++++++--------------
 modules/shepherd/support.scm |   11 ----------
 tests/basic.sh               |    8 +++++++
 4 files changed, 44 insertions(+), 26 deletions(-)

diff --git a/modules/herd.scm b/modules/herd.scm
index 7170e47..40bd10a 100644
--- a/modules/herd.scm
+++ b/modules/herd.scm
@@ -152,6 +152,13 @@ the daemon via SOCKET-FILE."
            (format (current-error-port)
                    (l10n "Service ~a does not have an action ~a.~%")
                    service action))
+          (('error ('version 0 _ ...) 'action-exception action service
+                   key (args ...))
+           (format (current-error-port)
+                   (l10n "Exception caught while executing '~a' \
+on service '~a':~%")
+                   action service)
+           (print-exception (current-error-port) #f key args))
           (('error . _)
            (format (current-error-port)
                    (l10n "Something went wrong: ~s~%")
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 1a5acc6..46dc4c7 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -195,6 +195,24 @@ respawned, shows that it has been respawned more than 
TIMES in SECONDS."
   (service unknown-action-service)
   (action  unknown-action-name))
 
+;; Report of an action throwing an exception in user code.
+(define-condition-type &action-runtime-error &service-error
+  action-runtime-error?
+  (service   action-runtime-error-service)
+  (action    action-runtime-error-action)
+  (key       action-runtime-error-key)
+  (arguments action-runtime-error-arguments))
+
+
+(define (report-exception action service key args)
+  "Report an exception of type KEY in user code ACTION of SERVICE."
+  ;; FIXME: Would be nice to log it without sending the message to the client.
+  (raise (condition (&action-runtime-error
+                     (service service)
+                     (action action)
+                     (key key)
+                     (arguments args)))))
+
 (define (condition->sexp condition)
   "Turn the SRFI-35 error CONDITION into an sexp that can be sent over the
 wire."
@@ -206,6 +224,12 @@ wire."
      `(error (version 0) action-not-found
              ,(unknown-action-name condition)
              ,(canonical-name (unknown-action-service condition))))
+    ((? action-runtime-error?)
+     `(error (version 0) action-exception
+             ,(action-runtime-error-action condition)
+             ,(canonical-name (action-runtime-error-service condition))
+             ,(action-runtime-error-key condition)
+             ,(map result->sexp (action-runtime-error-arguments condition))))
     ((? service-error?)
      `(error (version 0) service-error))))
 
@@ -277,8 +301,8 @@ wire."
                                               (apply (slot-ref obj 'start)
                                                      args))
                                             (lambda (key . args)
-                                              (caught-error key args)
-                                              #f))))))
+                                              (report-exception 'start obj
+                                                                key args)))))))
 
           ;; Status message.
           (local-output (if (running? obj)
@@ -378,17 +402,13 @@ wire."
           (else
            (catch #t
              (lambda ()
-               (if (can-apply? proc (+ 1 (length args)))
-                   (apply proc (slot-ref obj 'running) args)
-                   ;; FIXME: Better message.
-                   (local-output "Action ~a of service ~a can't take ~a 
arguments."
-                                 the-action (canonical-name obj) (length 
args))))
+               (apply proc (slot-ref obj 'running) args))
              (lambda (key . args)
                ;; Special case: `dmd' may quit.
                (and (eq? dmd-service obj)
                     (eq? key 'quit)
                     (apply quit args))
-               (caught-error key args)))))))
+               (report-exception the-action obj key args)))))))
 
 ;; Display documentation about the service.
 (define-method (doc (obj <service>) . args)
@@ -988,13 +1008,7 @@ requested to be removed."
   (local-output "Loading ~a." file-name)
   ;; Every action is protected anyway, so no need for a `catch'
   ;; here.  FIXME: What about `quit'?
-  (catch 'system-error
-    (lambda ()
-      (load-in-user-module file-name))
-    (lambda args
-      (local-output "Failed to load from '~a': ~a."
-                    file-name (strerror (system-error-errno args)))
-      #f)))
+  (load-in-user-module file-name))
 
 ;;; Tests for validity of the slots of <service> objects.
 
diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index 319fa91..2439085 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -26,7 +26,6 @@
             caught-error
             assert
             label
-            can-apply?
 
             catch-system-error
             with-system-error-handling
@@ -93,16 +92,6 @@
     (letrec ((NAME PROC))
       (apply NAME args))))
 
-;; Check whether a list of NUM-ARGS arguments can successfully be
-;; applied to PROC.
-(define (can-apply? proc num-args)
-  (and (procedure? proc)
-       (match (procedure-minimum-arity proc)
-         ((required optional rest?)
-          (and (>= num-args required)
-               (or rest? (<= num-args (+ required optional)))))
-         (_ #t))))
-
 ;; Evaluate `EXPR ...' until a system error occurs, then skip the
 ;; remaining code.
 (define-syntax-rule (catch-system-error EXPR ...)
diff --git a/tests/basic.sh b/tests/basic.sh
index e62e8dc..386b2b0 100644
--- a/tests/basic.sh
+++ b/tests/basic.sh
@@ -100,6 +100,14 @@ done
 if $herd an-action-that-does-not-exist dmd
 then false; else true; fi
 
+# Wrong number of arguments for an action.
+if $herd status dmd foo bar baz;
+then false; else true; fi
+
+# Loading nonexistent file.
+if $herd load dmd /does/not/exist.scm;
+then false; else true; fi
+
 # Unload one service, make sure the other it still around.
 $herd unload dmd test
 $herd status | grep "Stopped: (test-2)"