[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[shepherd] 01/05: Command replies are always sexps.
|
From: |
Ludovic Courtès |
|
Subject: |
[shepherd] 01/05: Command replies are always sexps. |
|
Date: |
Wed, 20 Jan 2016 21:16:52 +0000 |
civodul pushed a commit to branch master
in repository shepherd.
commit 7a841928ac8a5e01fe452895d244fe21b1541853
Author: Ludovic Courtès <address@hidden>
Date: Wed Jan 20 18:41:07 2016 +0100
Command replies are always sexps.
* modules/shepherd/comm.scm (<command-reply>): New type.
(write-reply): New procedure.
(result->sexp): New generic function.
* modules/shepherd/service.scm (condition->sexp): New procedure.
(action) <status>: Return OBJ instead of calling 'local-output'.
(service->sexp): Turn into a regular procedure.
(result->sexp): New method.
(action): Return the list of results.
(dmd-service) <status>: Return the service list. Remove 'local-output'
call.
* modules/shepherd.scm (process-connection): Remove 'paramterize' form.
(%not-newline): New variable.
(process-command): Add 'port' parameter. Parametrize
%CURRENT-CLIENT-SOCKET to a string output port. Use 'write-reply' to
send the reply.
(process-textual-commands): Pass PORT to 'process-command'.
* modules/herd.scm (display-status-summary): Expect SERVICES to be a
regular list.
(display-detailed-status): Likewise.
(display-service-status): Remove 'error' cases.
(println): New procedure.
(run-command): Match against 'reply' sexp.
* tests/basic.sh: Check the return code of "herd start" and "herd stop"
in addition to "herd status" for nonexistent services.
* tests/status-sexp.sh: Adjust to new protocol.
---
modules/herd.scm | 104 ++++++++++++++++++++++++------------------
modules/shepherd.scm | 69 ++++++++++++++++------------
modules/shepherd/comm.scm | 51 ++++++++++++++++++++-
modules/shepherd/service.scm | 55 ++++++++++++++--------
tests/basic.sh | 9 ++-
tests/status-sexp.sh | 39 +++++++++------
6 files changed, 213 insertions(+), 114 deletions(-)
diff --git a/modules/herd.scm b/modules/herd.scm
index 1351bde..3418465 100644
--- a/modules/herd.scm
+++ b/modules/herd.scm
@@ -53,29 +53,21 @@ of pairs."
(define (display-status-summary services)
"Display a summary of the status of all of SERVICES."
- (match services
- (('service-list ('version 0) services ...)
- (call-with-values
- (lambda ()
- (partition (match-lambda
- (('service ('version 0 _ ...) properties ...)
- (car (assoc-ref properties 'running))))
- services))
- (lambda (started stopped)
- (format #t (l10n "Started: ~a~%")
- (map service-canonical-name started))
- (format #t (l10n "Stopped: ~a~%")
- (map service-canonical-name stopped)))))
- (_
- (service-list-error services))))
+ (call-with-values
+ (lambda ()
+ (partition (match-lambda
+ (('service ('version 0 _ ...) properties ...)
+ (car (assoc-ref properties 'running))))
+ services))
+ (lambda (started stopped)
+ (format #t (l10n "Started: ~a~%")
+ (map service-canonical-name started))
+ (format #t (l10n "Stopped: ~a~%")
+ (map service-canonical-name stopped)))))
(define (display-detailed-status services)
"Display the detailed status of SERVICES."
- (match services
- (('service-list ('version 0) services ...)
- (for-each display-service-status services))
- (_
- (service-list-error services))))
+ (for-each display-service-status services))
(define (display-service-status service)
"Display the status of SERVICE, an sexp."
@@ -97,16 +89,11 @@ of pairs."
;; (format #t (l10n " Conflicts with ~a." (conflicts-with obj)))
(if respawn?
(format #t (l10n " Will be respawned.~%"))
- (format #t (l10n " Will not be respawned.~%")))))
- (('error ('version 0 _ ...) 'service-not-found service)
- (format (current-error-port)
- (l10n "Service ~a could not be found.~%")
- service)
- (exit 1))
- (('error . _)
- (format (current-error-port)
- (l10n "Something went wrong: ~s~%")
- service))))
+ (format #t (l10n " Will not be respawned.~%")))))))
+
+(define (println message)
+ (display message)
+ (newline))
(define (run-command socket-file action service args)
"Perform ACTION with ARGS on SERVICE, and display the result. Connect to
@@ -125,20 +112,49 @@ the daemon via SOCKET-FILE."
;; Interpret the command's output when possible and format it in a
;; human-readable way.
- (match (list action service)
- (('status 'dmd)
- (display-status-summary (read sock)))
- (('detailed-status 'dmd)
- (display-detailed-status (read sock)))
- (('status _)
- (display-service-status (read sock)))
- (_
- ;; For other commands, we don't do any interpretation.
- (let loop ((line (read-line sock)))
- (unless (eof-object? line)
- (display line)
- (newline)
- (loop (read-line sock))))))
+ (match (read sock)
+ (('reply ('version 0 _ ...) ;no errors
+ ('result result) (error #f)
+ ('messages messages))
+ ;; First, display raw messages coming from the daemon. Since they are
+ ;; not translated in the user's locale, they should be avoided!
+ (for-each println messages)
+
+ ;; Then interpret the result
+ (match (list action service)
+ (('status 'dmd)
+ (display-status-summary (first result)))
+ (('detailed-status 'dmd)
+ (display-detailed-status (first result)))
+ (('status _)
+ ;; We get a list of statuses, in case several services have the
+ ;; same name.
+ (for-each display-service-status result))
+ (_
+ ;; For other commands, we don't do any interpretation.
+ #t)))
+ (('reply ('version 0 _ ...) ;an error
+ ('result _) ('error error)
+ ('messages messages))
+ (for-each println messages)
+ (match error
+ (('error ('version 0 _ ...) 'service-not-found service)
+ (format (current-error-port)
+ (l10n "Service ~a could not be found.~%")
+ service)
+ (exit 1))
+ (('error . _)
+ (format (current-error-port)
+ (l10n "Something went wrong: ~s~%")
+ service)))
+ (exit 1))
+ ((? eof-object?)
+ ;; When stopping shepherd, we may get an EOF in lieu of a real reply,
+ ;; and that's fine. In other cases, a premature EOF is an error.
+ (unless (and (eq? action 'stop) (eq? service 'dmd))
+ (format (current-error-port)
+ (l10n "premature end-of-file while talking to shepherd~%"))
+ (exit 1))))
(close-port sock))))
diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 01097ea..b3224b9 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -209,18 +209,20 @@
(define (process-connection sock)
"Process client connection SOCK, reading and processing commands."
- (parameterize ((%current-client-socket sock))
- (catch 'system-error
- (lambda ()
- (process-command (read-command sock))
- ;; Currently we assume one command per connection.
- (false-if-exception (close sock)))
- (lambda args
- (false-if-exception (close sock))))))
+ (catch 'system-error
+ (lambda ()
+ (process-command (read-command sock) sock)
+ ;; Currently we assume one command per connection.
+ (false-if-exception (close sock)))
+ (lambda args
+ (false-if-exception (close sock)))))
+
+(define %not-newline
+ (char-set-complement (char-set #\newline)))
-(define (process-command command)
+(define (process-command command port)
"Interpret COMMAND, a command sent by the user, represented as a
-<dmd-command> object."
+<dmd-command> object. Send the reply to PORT."
(match command
(($ <dmd-command> the-action service-symbol (args ...) dir)
(chdir dir)
@@ -229,25 +231,33 @@
;; line to herd before we actually quit.
(catch 'quit
(lambda ()
- (guard (c ((missing-service-error? c)
- (case the-action
- ((status)
- ;; For these actions, we must always return an sexp.
- ;; TODO: Extend this to all actions.
- (display `(error (version 0) service-not-found
- ,(missing-service-name c))
- (%current-client-socket)))
- (else
- (local-output "Service ~a not found"
- (missing-service-name c))))))
- (case the-action
- ((start) (apply start service-symbol args))
- ((stop) (apply stop service-symbol args))
- ((enforce) (apply enforce service-symbol args))
+ (define message-port
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (open-output-string)))
+
+ (define (get-messages)
+ (string-tokenize (get-output-string message-port)
+ %not-newline))
+
+ (parameterize ((%current-client-socket message-port))
+ (guard (c ((missing-service-error? c)
+ (write-reply (command-reply command #f
+ (condition->sexp c)
+ (get-messages))
+ port)))
+
+ (define result
+ (case the-action
+ ((start) (apply start service-symbol args))
+ ((stop) (apply stop service-symbol args))
+ ((enforce) (apply enforce service-symbol args))
+
+ ;; Actions which have the semantics of `action' are
+ ;; handled there.
+ (else (apply action service-symbol the-action args))))
- ;; Actions which have the semantics of `action' are
- ;; handled there.
- (else (apply action service-symbol the-action args)))))
+ (write-reply (command-reply command result #f (get-messages))
+ port))))
(lambda (key)
;; Most likely we're receiving 'quit' from the 'stop' method of
;; DMD-SERVICE. So, if we're running as 'root', just reboot.
@@ -273,7 +283,8 @@ would write them on the 'herd' command line."
((action service arguments ...)
(process-command (dmd-command (string->symbol action)
(string->symbol service)
- #:arguments arguments)))
+ #:arguments arguments)
+ port))
(_
(local-output "invalid command line" line)))
(loop (read-line port))))))
diff --git a/modules/shepherd/comm.scm b/modules/shepherd/comm.scm
index 8f87a11..2402e7e 100644
--- a/modules/shepherd/comm.scm
+++ b/modules/shepherd/comm.scm
@@ -1,6 +1,6 @@
;; comm.scm -- Communication between processes and general output.
-;; Copyright (C) 2013, 2014 Ludovic Court�s <address@hidden>
-;; Copyright (C) 2002, 2003 Wolfgang J�hrling <address@hidden>
+;; Copyright (C) 2013, 2014, 2016 Ludovic Courtès <address@hidden>
+;; Copyright (C) 2002, 2003 Wolfgang Jährling <address@hidden>
;;
;; This file is part of the GNU Shepherd.
;;
@@ -33,9 +33,20 @@
dmd-command-service
dmd-command-arguments
+ <command-reply>
+ command-reply
+ command-reply?
+ command-reply-command
+ command-reply-result
+ command-reply-error
+ command-reply-messages
+
write-command
read-command
+ write-reply
+ result->sexp
+
start-logging
stop-logging
%current-client-socket
@@ -99,6 +110,42 @@ return the socket."
port))))
+;; Replies to commands.
+
+(define-record-type <command-reply>
+ (command-reply command result error messages)
+ command-reply?
+ (command command-reply-command) ;command
+ (result command-reply-result) ;sexp | #f
+ (error command-reply-error) ;#f | sexp
+ (messages command-reply-messages)) ;list of strings
+
+(define (write-reply reply port)
+ "Write REPLY to PORT."
+ (match reply
+ (($ <command-reply> command result error (messages ...))
+ ;; Use 'result->sexp' to convert RESULT to an sexp. We don't do that for
+ ;; ERROR because using GOOPS methods doesn't work for SRFI-35 error
+ ;; conditions, and that's what we're using here. (XXX)
+ (write `(reply (version 0)
+ (result ,(result->sexp result))
+ (error ,error)
+ (messages ,messages))
+ port))))
+
+;; This generic function must be extended to provide sexp representations of
+;; results that go in <command-reply> objects.
+(define-generic result->sexp)
+
+(define-method (result->sexp (bool <boolean>)) bool)
+(define-method (result->sexp (number <number>)) number)
+(define-method (result->sexp (symbol <symbol>)) symbol)
+(define-method (result->sexp (string <string>)) string)
+(define-method (result->sexp (list <list>)) (map result->sexp list))
+(define-method (result->sexp (kw <keyword>)) kw)
+(define-method (result->sexp (obj <top>)) (object->string obj))
+
+
;; Port for logging. This must always be a valid port, never `#f'.
(define log-output-port (%make-void-port "w"))
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 453b48a..8440f7c 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -76,7 +76,9 @@
service-error?
&missing-service-error
missing-service-error?
- missing-service-name))
+ missing-service-name
+
+ condition->sexp))
;; Conveniently create an actions object containing the actions for a
;; <service> object. The current structure is a list of actions,
@@ -183,6 +185,15 @@ respawned, shows that it has been respawned more than
TIMES in SECONDS."
missing-service-error?
(name missing-service-name))
+(define (condition->sexp condition)
+ "Turn the SRFI-35 error CONDITION into an sexp that can be sent over the
+wire."
+ (match condition
+ ((? missing-service-error?)
+ `(error (version 0) service-not-found
+ ,(missing-service-name condition)))
+ ((? service-error?)
+ `(error (version 0) service-error))))
;; Return the canonical name of the service.
(define-method (canonical-name (obj <service>))
@@ -323,8 +334,9 @@ respawned, shows that it has been respawned more than TIMES
in SECONDS."
(local-output "~a was not running." (canonical-name obj)))
(start obj))
((status)
- ;; Return the raw sexp and let the client present it nicely.
- (local-output "~s" (service->sexp obj)))
+ ;; Return the service itself. It is automatically converted to an sexp
+ ;; via 'result->sexp' and sent to the client.
+ obj)
(else
;; FIXME: Unknown service.
(local-output "Service ~a does not have a ~a action."
@@ -420,7 +432,7 @@ respawned, shows that it has been respawned more than TIMES
in SECONDS."
(for-each stop (conflicts-with-running obj))
(apply start obj args))
-(define-method (service->sexp (service <service>))
+(define (service->sexp service)
"Return a representation of SERVICE as an sexp meant to be consumed by
clients."
`(service (version 0) ;protocol version
@@ -434,6 +446,10 @@ clients."
(running ,(slot-ref service 'running))
(last-respawns ,(slot-ref service 'last-respawns))))
+(define-method (result->sexp (service <service>))
+ ;; Serialize SERVICE to an sexp.
+ (service->sexp service))
+
;; Return whether OBJ requires something that is not yet running.
(define-method (depends-resolved? (obj <service>))
(every lookup-running (required-by obj)))
@@ -480,8 +496,9 @@ clients."
(raise (condition (&missing-service-error (name obj))))))
(apply stop which args))))
-;; Perform action THE-ACTION by name.
(define-method (action (obj <symbol>) the-action . args)
+ "Perform THE-ACTION on all the services named OBJ. Return the list of
+results."
(let ((which-services (lookup-running-or-providing obj)))
(if (null? which-services)
(let ((unknown (lookup-running 'unknown)))
@@ -489,17 +506,17 @@ clients."
(defines-action? unknown 'action))
(apply action unknown 'action the-action args)
(raise (condition (&missing-service-error (name obj))))))
- (for-each (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))
- which-services))))
+ (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))
+ which-services))))
;; EINTR-safe versions of 'system' and 'system*'.
@@ -1019,10 +1036,8 @@ file when persistence is enabled."
"Return an s-expression showing information about all the services.
Clients such as 'herd' can read it and format it in a human-readable way."
(lambda (running)
- (local-output "~s~%"
- `(service-list
- (version 0) ;protocol version
- ,@(map service->sexp (service-list))))))
+ ;; Return the list of services.
+ (service-list)))
;; Halt.
(halt
diff --git a/tests/basic.sh b/tests/basic.sh
index e7865a4..12fca19 100644
--- a/tests/basic.sh
+++ b/tests/basic.sh
@@ -83,10 +83,13 @@ $herd start test-2
$herd status test-2 | grep started
-if $herd status does-not-exist
-then false; else true; fi
+for action in status start stop
+do
+ if $herd $action does-not-exist
+ then false; else true; fi
-$herd status does-not-exist 2>&1 | grep "does-not-exist.*not.*found"
+ $herd $action does-not-exist 2>&1 | grep "does-not-exist.*not.*found"
+done
# Unload one service, make sure the other it still around.
$herd unload dmd test
diff --git a/tests/status-sexp.sh b/tests/status-sexp.sh
index 629e9dc..a16c847 100644
--- a/tests/status-sexp.sh
+++ b/tests/status-sexp.sh
@@ -73,22 +73,24 @@ dmd_service_sexp="
(enabled? #t) (running #t) (last-respawns ()))"
"$GUILE" -c "
-(use-modules (shepherd comm) (srfi srfi-1))
+(use-modules (shepherd comm) (srfi srfi-1) (ice-9 match))
(exit
- (lset= equal? $fetch_status
- '(service-list (version 0)
- $dmd_service_sexp
- (service (version 0)
- (provides (foo)) (requires ())
- (respawn? #t) (docstring \"Foo!\")
- (enabled? #t) (running 42)
- (last-respawns ()))
- (service (version 0)
- (provides (bar)) (requires (foo))
- (respawn? #f) (docstring \"Bar!\")
- (enabled? #t) (running #f)
- (last-respawns ())))))
+ (match $fetch_status
+ (('reply _ ('result (services)) ('error #f) ('messages ()))
+ (lset= equal?
+ services
+ '($dmd_service_sexp
+ (service (version 0)
+ (provides (foo)) (requires ())
+ (respawn? #t) (docstring \"Foo!\")
+ (enabled? #t) (running 42)
+ (last-respawns ()))
+ (service (version 0)
+ (provides (bar)) (requires (foo))
+ (respawn? #f) (docstring \"Bar!\")
+ (enabled? #t) (running #f)
+ (last-respawns ())))))))
"
# Make sure we get an 'error' sexp when querying a nonexistent service.
@@ -98,7 +100,9 @@ dmd_service_sexp="
(match (let ((sock (open-connection \"$socket\")))
(write-command (dmd-command 'status 'does-not-exist) sock)
(read sock))
- (('error _ ... 'service-not-found 'does-not-exist)
+ (('reply _ ...
+ ('error ('error _ 'service-not-found 'does-not-exist))
+ ('messages ()))
#t)
(x
(pk 'wrong x)
@@ -112,7 +116,10 @@ $herd unload dmd all
(exit
(equal? $fetch_status
- '(service-list (version 0) $dmd_service_sexp)))"
+ '(reply
+ (version 0)
+ (result (($dmd_service_sexp)))
+ (error #f) (messages ()))))"
$herd stop dmd
! kill -0 $dmd_pid