[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[shepherd] 05/05: Add '&action-runtime-error'.
From: |
Ludovic Courtès |
Subject: |
[shepherd] 05/05: Add '&action-runtime-error'. |
Date: |
Wed, 20 Jan 2016 21:16:54 +0000 |
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)"