[dmd] 05/05: service: 'status' always returns an sexp; 'deco' interprets it.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository dmd.

commit 2f204c9d8077dbd6a7c94227bbffbc0cbfd289c3
Author: Ludovic Courtès <address@hidden>
Date:   Sat Jan 9 15:36:58 2016 +0100

    service: 'status' always returns an sexp; 'deco' interprets it.
    
    This moves formatting (and localization) of 'status' command outputs to
    the client side.
    
    * modules/dmd/service.scm (action)[status]: Write (service->sexp obj)
    instead of calling 'dmd-status'.
    (dmd-status): Remove.
    * modules/dmd/service.scm (dmd-service) <actions>: Remove 'sexp-status'
    and 'detailed-status'; 'status' now does what 'sexp-status' used to do.
    * modules/deco.scm (service-list-error, service-canonical-name)
    (display-status-summary, display-detailed-status)
    (display-service-status): New procedure.
    (alist-let*): New macro.
    * modules/deco.scm (run-command): Special-case the 'status' and
    'detailed-status' commands, using the above procedures.  Close SOCK
    before returning.
    * Makefile.am (AM_TESTS_ENVIRONMENT): Add 'GUILE', 'GUILE_LOAD_PATH',
    and 'GUILE_LOAD_COMPILED_PATH'.
    * tests/status-sexp.sh (fetch_status): New variable.
    Use "$GUILE" when invoking Guile.  Use the (dmd comm) module and
    FETCH_STATUS to fetch the status sexp.
---
 Makefile.am             |    4 +-
 modules/deco.scm        |  102 +++++++++++++++++++++++++++++++++++++++++++---
 modules/dmd/service.scm |   48 ++--------------------
 tests/status-sexp.sh    |   18 ++++++--
 4 files changed, 115 insertions(+), 57 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 3c4a642..f3e33b9 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -144,7 +144,9 @@ EXTRA_DIST += $(TESTS)
 
 AM_TESTS_ENVIRONMENT =                         \
   PATH="$(abs_top_builddir):$$PATH" LC_ALL=C   \
-  SHELL="$(SHELL)"
+  SHELL="$(SHELL)" GUILE="$(GUILE)"
+  
GUILE_LOAD_PATH="$(abs_top_srcdir)/modules:$(abs_top_builddir)/modules:$$GUILE_LOAD_PATH"
 \
+  
GUILE_LOAD_COMPILED_PATH="$(abs_top_srcdir)/modules:$(abs_top_builddir)/modules:$$GUILE_LOAD_COMPILED_PATH"
 
 SH_LOG_COMPILER = $(SHELL)
 AM_SH_LOG_FLAGS = -x -e
diff --git a/modules/deco.scm b/modules/deco.scm
index 87f27c2..339e415 100644
--- a/modules/deco.scm
+++ b/modules/deco.scm
@@ -32,24 +32,108 @@
 (define program-name "deco")
 
 
+(define (service-list-error services)
+  (format (current-error-port)
+          (l10n "~a: error: received an invalid service list:~%~s~%")
+          program-name services))
+
+(define-syntax alist-let*
+  (syntax-rules ()
+    "Bind the given KEYs in EXP to the corresponding items in ALIST.  ALIST
+is assumed to be a list of two-element tuples rather than a traditional list
+of pairs."
+    ((_ alist (key ...) exp ...)
+     (let ((key (and=> (assoc-ref alist 'key) car)) ...)
+       exp ...))))
+
+(define service-canonical-name
+  (match-lambda
+    (('service ('version 0 _ ...) (provides (name0 _ ...)) _ ...)
+     name0)))
+
+(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))))
+
+(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))))
+
+(define (display-service-status service)
+  "Display the status of SERVICE, an sexp."
+  (match service
+    (('service ('version 0 _ ...) properties ...)
+     (alist-let* properties (provides requires running respawn? enabled?)
+       (format #t (l10n "Status of ~a:~%") (first provides))
+       (if running
+           (begin
+             (format #t (l10n "  It is started.~%"))
+             (format #t (l10n "  Running value is ~s.~%") running))
+           (format #t (l10n "  It is stopped.~%")))
+       (if enabled?
+           (format #t (l10n "  It is enabled.~%"))
+           (format #t (l10n "  It is disabled.~%")))
+       (format #t (l10n "  Provides ~a.~%") provides)
+       (format #t (l10n "  Requires ~a.~%") requires)
+       ;; FIXME: We don't have that information.
+       ;; (format #t (l10n "  Conflicts with ~a." (conflicts-with obj)))
+       (if respawn?
+           (format #t (l10n "  Will be respawned.~%"))
+           (format #t (l10n "  Will not be respawned.~%")))))))
 
 (define (run-command socket-file action service args)
   "Perform ACTION with ARGS on SERVICE, and display the result.  Connect to
 the daemon via SOCKET-FILE."
   (with-system-error-handling
-   (let ((sock (open-connection socket-file)))
+   (let ((sock    (open-connection socket-file))
+         (action* (if (and (eq? service 'dmd) (eq? action 'detailed-status))
+                      'status
+                      action)))
      ;; Send the command.
-     (write-command (dmd-command action service #:arguments args)
+     (write-command (dmd-command action* service #:arguments args)
                     sock)
 
      ;; Receive output.
      (setvbuf sock _IOLBF)
-     (let loop ((line (read-line sock)))
-       (unless (eof-object? line)
-         (display line)
-         (newline)
-         (loop (read-line sock)))))))
 
+     ;; 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))))))
+
+     (close-port sock))))
+
+
 ;; Main program.
 (define (main . args)
   (false-if-exception (setlocale LC_ALL ""))
@@ -82,3 +166,7 @@ the daemon via SOCKET-FILE."
        (format (current-error-port)
                (l10n "Usage: deco ACTION [SERVICE [OPTIONS...]]~%"))
        (exit 1)))))
+
+;; Local Variables:
+;; eval: (put 'alist-let* 'scheme-indent-function 2)
+;; End:
diff --git a/modules/dmd/service.scm b/modules/dmd/service.scm
index bde1cae..f859ca3 100644
--- a/modules/dmd/service.scm
+++ b/modules/dmd/service.scm
@@ -45,7 +45,6 @@
             doc
             conflicts-with
             conflicts-with-running
-            dmd-status
             depends-resolved?
             launch-service
             first-running
@@ -308,7 +307,8 @@ respawned, shows that it has been respawned more than TIMES 
in SECONDS."
         (local-output "~a was not running." (canonical-name obj)))
        (start obj))
       ((status)
-       (dmd-status obj))
+       ;; Return the raw sexp and let the client present it nicely.
+       (local-output "~s" (service->sexp obj)))
       (else
        ;; FIXME: Unknown service.
        (local-output "Service ~a does not have a ~a action."
@@ -417,25 +417,6 @@ respawned, shows that it has been respawned more than 
TIMES in SECONDS."
   (for-each stop (conflicts-with-running obj))
   (apply start obj args))
 
-;; Display information about the service.
-(define-method (dmd-status (obj <service>))
-  (local-output "Status of ~a:"
-               (canonical-name obj))
-  (if (running? obj)
-      (begin
-        (local-output "  It is started.")
-        (local-output "  Running value is ~s." (slot-ref obj 'running)))
-      (local-output "  It is stopped."))
-  (if (enabled? obj)
-      (local-output "  It is enabled.")
-      (local-output "  It is disabled."))
-  (local-output "  Provides ~a." (provided-by obj))
-  (local-output "  Requires ~a." (required-by obj))
-  (local-output "  Conflicts with ~a." (conflicts-with obj))
-  (if (respawn? obj)
-      (local-output "  Will be respawned.")
-    (local-output "  Will not be respawned.")))
-
 (define-method (service->sexp (service <service>))
   "Return a representation of SERVICE as an sexp meant to be consumed by
 clients."
@@ -1061,30 +1042,9 @@ file when persistence is enabled."
     ;; allowed to quit, while user-supplied code shouldn't be.
     #:actions
     (make-actions
-     ;; Display status.
      (status
-      "Display the status of dmd.  I.e. which services are running and
-which ones are not."
-      (lambda (running)
-       (let ((started '()) (stopped '()))
-         (for-each-service
-          (lambda (service)
-            (if (running? service)
-                (set! started (cons (canonical-name service)
-                                    started))
-                 (set! stopped (cons (canonical-name service)
-                                     stopped)))))
-         (local-output "Started: ~a" started)
-         (local-output "Stopped: ~a" stopped))))
-     ;; Look at every service in detail.
-     (detailed-status
-      "Display detailed information about all services."
-      (lambda (running)
-       (for-each-service dmd-status)))
-
-     ;; Same, but send the result as an sexp.
-     (status-sexp
-      "Return an s-expression showing information about all the services."
+      "Return an s-expression showing information about all the services.
+Clients such as 'deco' can read it and format it in a human-readable way."
       (lambda (running)
         (local-output "~s~%"
                       `(service-list
diff --git a/tests/status-sexp.sh b/tests/status-sexp.sh
index e55566a..6a8f4f8 100644
--- a/tests/status-sexp.sh
+++ b/tests/status-sexp.sh
@@ -59,6 +59,12 @@ dmd_pid="`cat $pid`"
 kill -0 $dmd_pid
 test -S "$socket"
 
+# Code to fetch service status info.
+fetch_status="
+  (let ((sock (open-connection \"$socket\")))
+    (write-command (dmd-command 'status 'dmd) sock)
+    (read sock))"
+
 dmd_service_sexp="
    (service (version 0)
       (provides (dmd)) (requires ())
@@ -66,11 +72,11 @@ dmd_service_sexp="
       (docstring \"The dmd service is used to operate on dmd itself.\")
       (enabled? #t) (running #t) (last-respawns ()))"
 
-guile -c "
-(use-modules (srfi srfi-1))
+"$GUILE" -c "
+(use-modules (dmd comm) (srfi srfi-1))
 
 (exit
- (lset= equal? '`$deco status-sexp dmd`
+ (lset= equal? $fetch_status
               '(service-list (version 0)
                   $dmd_service_sexp
                  (service (version 0)
@@ -88,9 +94,11 @@ guile -c "
 # Unload everything and make sure only 'dmd' is left.
 $deco unload dmd all
 
-guile -c "
+"$GUILE" -c "
+(use-modules (dmd comm))
+
 (exit
-  (equal? '`$deco status-sexp dmd`
+  (equal? $fetch_status
           '(service-list (version 0) $dmd_service_sexp)))"
 
 $deco stop dmd