guix-commits
[Top][All Lists]
Advanced

[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



reply via email to

[Prev in Thread] Current Thread [Next in Thread]