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

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit a70b2caaa972655865239c3d6e1d8820108b72e4
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jan 20 21:21:58 2016 +0100

    Add '&unknown-action-error'.
    
    * modules/shepherd/service.scm (&unknown-action-error): New error
    condition type.
    (condition->sexp): Handle it.
    (action)[default-action]: Raise it instead of using 'local-output'.
    Adjust body so that SRFI-34 exception is not swallowed.
    * modules/shepherd.scm (process-command): Guard against 'service-error?'
    in general.
    * modules/herd.scm (run-command): Handle 'action-not-found' errors.
---
 modules/herd.scm             |    9 ++++--
 modules/shepherd.scm         |    2 +-
 modules/shepherd/service.scm |   59 +++++++++++++++++++++++++++---------------
 tests/basic.sh               |    3 ++
 4 files changed, 48 insertions(+), 25 deletions(-)

diff --git a/modules/herd.scm b/modules/herd.scm
index 3418465..9b4b272 100644
--- a/modules/herd.scm
+++ b/modules/herd.scm
@@ -141,12 +141,15 @@ the daemon via SOCKET-FILE."
           (('error ('version 0 _ ...) 'service-not-found service)
            (format (current-error-port)
                    (l10n "Service ~a could not be found.~%")
-                   service)
-           (exit 1))
+                   service))
+          (('error ('version 0 _ ...) 'action-not-found action service)
+           (format (current-error-port)
+                   (l10n "Service ~a does not have an action ~a.~%")
+                   service action))
           (('error . _)
            (format (current-error-port)
                    (l10n "Something went wrong: ~s~%")
-                   service)))
+                   error)))
         (exit 1))
        ((? eof-object?)
         ;; When stopping shepherd, we may get an EOF in lieu of a real reply,
diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index b3224b9..9ad3d09 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -240,7 +240,7 @@
                             %not-newline))
 
          (parameterize ((%current-client-socket message-port))
-           (guard (c ((missing-service-error? c)
+           (guard (c ((service-error? c)
                       (write-reply (command-reply command #f
                                                   (condition->sexp c)
                                                   (get-messages))
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 8440f7c..212d25d 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -78,6 +78,11 @@
             missing-service-error?
             missing-service-name
 
+            &unknown-action-error
+            unknown-action-error?
+            unknown-action-name
+            unknown-action-service
+
             condition->sexp))
 
 ;; Conveniently create an actions object containing the actions for a
@@ -185,6 +190,11 @@ respawned, shows that it has been respawned more than 
TIMES in SECONDS."
   missing-service-error?
   (name missing-service-name))
 
+(define-condition-type &unknown-action-error &service-error
+  unknown-action-error?
+  (service unknown-action-service)
+  (action  unknown-action-name))
+
 (define (condition->sexp condition)
   "Turn the SRFI-35 error CONDITION into an sexp that can be sent over the
 wire."
@@ -192,6 +202,10 @@ wire."
     ((? missing-service-error?)
      `(error (version 0) service-not-found
              ,(missing-service-name condition)))
+    ((? unknown-action-error?)
+     `(error (version 0) action-not-found
+             ,(unknown-action-name condition)
+             ,(canonical-name (unknown-action-service condition))))
     ((? service-error?)
      `(error (version 0) service-error))))
 
@@ -331,7 +345,7 @@ wire."
       ((restart)
        (if running
           (stop obj)
-        (local-output "~a was not running." (canonical-name obj)))
+           (local-output "~a was not running." (canonical-name obj)))
        (start obj))
       ((status)
        ;; Return the service itself.  It is automatically converted to an sexp
@@ -339,14 +353,14 @@ wire."
        obj)
       (else
        ;; FIXME: Unknown service.
-       (local-output "Service ~a does not have a ~a action."
-                    (canonical-name obj)
-                    the-action))))
+       (raise (condition (&unknown-action-error
+                          (service obj)
+                          (action the-action)))))))
 
   (define (apply-if-pair obj proc)
     (if (pair? obj)
        (proc obj)
-      obj))
+        obj))
 
   (let ((proc (or (apply-if-pair (lookup-action obj the-action)
                                 action:proc)
@@ -356,22 +370,25 @@ wire."
     ;; information.
     ;; FIXME: Why should the user-implementations not be allowed to be
     ;; called this way?
-    (if (and (not (eq? proc default-action))
-            (not (running? obj)))
-       (local-output "Service ~a is not running." (canonical-name obj))
-      (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))))
-       (lambda (key . args)
-         ;; Special case: `dmd' may quit.
-         (and (eq? dmd-service obj)
-              (eq? key 'quit)
-              (apply quit args))
-         (caught-error key args))))))
+    (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 ()
+               (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))))
+             (lambda (key . args)
+               ;; Special case: `dmd' may quit.
+               (and (eq? dmd-service obj)
+                    (eq? key 'quit)
+                    (apply quit args))
+               (caught-error key args)))))))
 
 ;; Display documentation about the service.
 (define-method (doc (obj <service>) . args)
diff --git a/tests/basic.sh b/tests/basic.sh
index 12fca19..f55ee2b 100644
--- a/tests/basic.sh
+++ b/tests/basic.sh
@@ -91,6 +91,9 @@ do
     $herd $action does-not-exist 2>&1 | grep "does-not-exist.*not.*found"
 done
 
+if $herd an-action-that-does-not-exist dmd
+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)"