[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[shepherd] 01/02: service: Protect against wrong number of arguments to
From: |
Ludovic Courtès |
Subject: |
[shepherd] 01/02: service: Protect against wrong number of arguments to 'enable' etc. |
Date: |
Sun, 16 Oct 2016 13:50:27 +0000 (UTC) |
civodul pushed a commit to branch master
in repository shepherd.
commit 9161450cb800f09ba617f456df9d2ec55ebf242b
Author: Ludovic Courtès <address@hidden>
Date: Sun Oct 16 15:31:23 2016 +0200
service: Protect against wrong number of arguments to 'enable' etc.
Fixes <http://bugs.gnu.org/24684>.
Reported by Caleb Ristvedt <address@hidden>.
* modules/shepherd/service.scm (action)[default-action]: Add 'enable',
'disable', and 'doc'.
Move 'catch' form around the 'cond' expression.
(action) <symbol>: Invoke the other 'action' method.
* tests/basic.sh: Add test.
---
modules/shepherd/service.scm | 50 +++++++++++++++++++++---------------------
tests/basic.sh | 7 ++++++
2 files changed, 32 insertions(+), 25 deletions(-)
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index d3fb348..675639e 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -402,6 +402,12 @@ wire."
;; Return the service itself. It is automatically converted to an sexp
;; via 'result->sexp' and sent to the client.
obj)
+ ((enable)
+ (enable obj))
+ ((disable)
+ (disable obj))
+ ((doc)
+ (apply doc obj args))
(else
;; FIXME: Unknown service.
(raise (condition (&unknown-action-error
@@ -416,21 +422,23 @@ wire."
;; information.
;; FIXME: Why should the user-implementations not be allowed to be
;; called this way?
- (cond ((eq? proc default-action)
- (apply default-action (slot-ref obj 'running) args))
- ((not (running? obj))
- (local-output "Service ~a is not running." (canonical-name obj))
- #f)
- (else
- (catch #t
- (lambda ()
- (apply proc (slot-ref obj 'running) args))
- (lambda (key . args)
- ;; Special case: 'root' may quit.
- (and (eq? root-service obj)
- (eq? key 'quit)
- (apply quit args))
- (report-exception the-action obj key args)))))))
+ (catch #t
+ (lambda ()
+ (cond ((eq? proc default-action)
+ (apply default-action (slot-ref obj 'running) args))
+ ((not (running? obj))
+ (local-output "Service ~a is not running." (canonical-name obj))
+ #f)
+ (else
+ (apply proc (slot-ref obj 'running) args))))
+ (lambda (key . args)
+ ;; Special case: 'root' may quit.
+ (and (eq? root-service obj)
+ (eq? key 'quit)
+ (apply quit args))
+ (if (eq? key 'srfi-34)
+ (apply throw key args) ;handled by callers
+ (report-exception the-action obj key args))))))
;; Display documentation about the service.
(define-method (doc (obj <service>) . args)
@@ -567,16 +575,8 @@ results."
(defines-action? unknown 'action))
(apply action unknown 'action the-action args)
(raise (condition (&missing-service-error (name obj))))))
- (map (lambda (s)
- (apply (case the-action
- ((enable) enable)
- ((disable) disable)
- ((doc) doc)
- (else
- (lambda (s . further-args)
- (apply action s the-action further-args))))
- s
- args))
+ (map (lambda (service)
+ (apply action service the-action args))
which-services))))
;; EINTR-safe versions of 'system' and 'system*'.
diff --git a/tests/basic.sh b/tests/basic.sh
index 18884b9..f706ec9 100644
--- a/tests/basic.sh
+++ b/tests/basic.sh
@@ -94,6 +94,9 @@ then false; else true; fi
$herd enable test-2
$herd start test-2
+# This used to crash shepherd: <http://bugs.gnu.org/24684>.
+$herd enable test-2 with extra arguments
+
$herd status test-2 | grep started
for action in status start stop
@@ -119,6 +122,10 @@ $herd doc root action status
if $herd doc root action an-action-that-does-not-exist
then false; else true; fi
+# Make sure the error message is correct.
+$herd doc root action an-action-that-does-not-exist 2>&1 | \
+ grep "does not have an action 'an-action-that-does-not-exist'"
+
# Loading nonexistent file.
if $herd load root /does/not/exist.scm;
then false; else true; fi