[shepherd] 06/10: herd: Add 'graph' action.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit fb1c285d0149ae1d2df5b1769597a26acfcc9475
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Apr 27 12:12:42 2023 +0200

    herd: Add 'graph' action.
    
    * modules/shepherd/scripts/herd.scm (display-service-graph): New
    procedure.
    (run-command, main): Handle 'graph' action.
    * tests/basic.sh: Add test.
    * doc/shepherd.texi (Jump Start, Defining Services): Mention 'herd
    graph'.
---
 doc/shepherd.texi                 | 18 ++++++++++
 modules/shepherd/scripts/herd.scm | 74 +++++++++++++++++++++++++++++++++++++--
 tests/basic.sh                    |  2 ++
 3 files changed, 92 insertions(+), 2 deletions(-)

diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 99efe56..5e18927 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -202,6 +202,14 @@ each service was started or stopped, by running:
 herd log
 @end example
 
+Services and their dependencies form a @dfn{graph}, which you can view,
+for instance with the help of
+@uref{https://github.com/jrfonseca/xdot.py, xdot}, by running:
+
+@example
+herd graph | xdot -
+@end example
+
 @cindex Stopping a service
 You can stop
 a service and all the services that depend on it will be stopped.
@@ -749,6 +757,16 @@ A special service that every other service implicitly 
depends on is the
 @code{root} (also known as @code{shepherd}) service.  @xref{The root
 Service}, for more information.
 
+@cindex graph of services
+Services and their dependencies form a @dfn{graph}.  At the
+command-line, you can view that export a representation of that graph
+that can be consumed by any application that understands the Graphviz
+format, such as @uref{https://github.com/jrfonseca/xdot.py, xdot}:
+
+@example
+herd graph | xdot -
+@end example
+
 Service actions are defined using the @code{actions} macro, as
 shown below.
 
diff --git a/modules/shepherd/scripts/herd.scm 
b/modules/shepherd/scripts/herd.scm
index 4d22bff..983c7b4 100644
--- a/modules/shepherd/scripts/herd.scm
+++ b/modules/shepherd/scripts/herd.scm
@@ -25,10 +25,12 @@
   #:use-module (shepherd colors)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 match)
+  #:autoload   (ice-9 vlist) (vlist-null vhash-consq vhash-assq)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-71)
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
   #:export (main))
 
 
@@ -334,6 +336,71 @@ into a @code{live-service} record."
                             name status))))))
             (reverse sorted)))
 
+(define (display-service-graph services)
+  "Write to the current output port a Graphviz representation of
+@var{services}."
+  (define registry
+    (fold (lambda (service registry)
+            (fold (cut vhash-consq <> service <>)
+                  registry
+                  (live-service-provision service)))
+          vlist-null
+          services))
+
+  (define (lookup-service name)
+    (match (vhash-assq name registry)
+      (#f
+       (report-error (l10n "inconsistent graph: service '~a' not found~%")
+                     name)
+       (exit 1))
+      ((_ . service) service)))
+
+  (define (emit-graphviz services)
+    (define (shape service)
+      (if (live-service-one-shot? service)
+          "circle"
+          "box"))
+    (define (style service)
+      (if (live-service-transient? service)
+          "dashed"
+          "solid"))
+    (define (text-color service)
+      (cond ((live-service-failing? service)
+             "red")
+            ((eq? (live-service-status service) 'stopped)
+             "purple")
+            ((eq? (live-service-status service) 'running)
+             "black")
+            (else
+             "gray")))
+    (define (color service)
+      (cond ((live-service-failing? service)
+             "red")
+            ((eq? (live-service-status service) 'stopped)
+             "purple")
+            ((eq? (live-service-status service) 'running)
+             "green")
+            (else
+             "gray")))
+
+    (format #t "digraph ~s {~%" (l10n "Service Graph"))
+    (for-each (lambda (service)
+                (format #t "  \"~a\" [shape = ~a, color = ~a, \
+fontcolor = ~a, style = ~a];~%"
+                        (live-service-canonical-name service)
+                        (shape service) (color service)
+                        (text-color service) (style service))
+                (for-each (lambda (dependency)
+                            (format #t "  \"~a\" -> \"~a\";~%"
+                                    (live-service-canonical-name service)
+                                    (live-service-canonical-name
+                                     (lookup-service dependency))))
+                          (live-service-requirement service)))
+              services)
+    (format #t "}~%"))
+
+  (emit-graphviz services))
+
 (define root-service?
   ;; XXX: This procedure is written in a surprising way to work around a
   ;; compilation bug in Guile 3.0.5 to 3.0.7: <https://bugs.gnu.org/47172>.
@@ -346,7 +413,7 @@ into a @code{live-service} record."
 the daemon via SOCKET-FILE."
   (with-system-error-handling
    (let ((sock    (open-connection socket-file))
-         (action* (if (and (memq action '(detailed-status log))
+         (action* (if (and (memq action '(detailed-status log graph))
                            (root-service? service))
                       'status
                       action)))
@@ -375,6 +442,9 @@ the daemon via SOCKET-FILE."
           (('log (or 'root 'shepherd))
            (display-event-log
             (map sexp->live-service (first result))))
+          (('graph (or 'root 'shepherd))
+           (display-service-graph
+            (map sexp->live-service (first result))))
           (('help (or 'root 'shepherd))
            (match result
              ((help-text)
@@ -443,7 +513,7 @@ SERVICE with the ARGs.")
 
       (match (reverse command-args)
         (((and action
-               (or "status" "detailed-status" "help" "log"))) ;one argument
+               (or "status" "detailed-status" "help" "log" "graph"))) ;one 
argument
          (run-command socket-file (string->symbol action) 'root '()))
         ((action service args ...)
          (run-command socket-file
diff --git a/tests/basic.sh b/tests/basic.sh
index ce8aa57..cd1484b 100644
--- a/tests/basic.sh
+++ b/tests/basic.sh
@@ -87,6 +87,8 @@ test -S "$socket"
 pristine_status=`$herd status root` # Prep for 'reload' test.
 echo $pristine_status | grep -E '(Start.*root|Stop.*test)'
 
+$herd graph | grep '"test-2" -> "test"'
+
 $herd start test
 test -f "$stamp"
 $herd status test | grep running