09/10: guix system: Add 'dmd-graph' command.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 6f305ea5fdb239bdac5ab9c1d7b837f3177a025a
Author: Ludovic Courtès <address@hidden>
Date:   Wed Oct 14 19:17:12 2015 +0200

    guix system: Add 'dmd-graph' command.
    
    * guix/scripts/system.scm (dmd-service-node-label,
      dmd-service-node-type, export-dmd-graph): New procedures.
      (show-help): Add 'dmd-graph'.
      (guix-system)[parse-sub-command]: Likewise.
      Honor it.
    * doc/guix.texi (Invoking guix system): Document it.
      (dmd Services): Add an illustration and explanation.
    * doc/images/dmd-graph.dot: New file.
    * doc.am (DOT_FILES): Add it.
---
 .gitignore               |    1 +
 doc.am                   |    3 +-
 doc/guix.texi            |   27 ++++++++++++++--
 doc/images/dmd-graph.dot |   75 ++++++++++++++++++++++++++++++++++++++++++++++
 guix/scripts/system.scm  |   34 +++++++++++++++++++-
 5 files changed, 133 insertions(+), 7 deletions(-)

diff --git a/.gitignore b/.gitignore
index e3f2ac2..6e8bfac 100644
--- a/.gitignore
+++ b/.gitignore
@@ -132,3 +132,4 @@ GTAGS
 /doc/images/service-graph.png
 /doc/images/service-graph.eps
 /doc/images/service-graph.pdf
+/doc/images/dmd-graph.png
diff --git a/doc.am b/doc.am
index 71a65ba..1980cc8 100644
--- a/doc.am
+++ b/doc.am
@@ -23,7 +23,8 @@ DOT_FILES =                                   \
   doc/images/bootstrap-graph.dot               \
   doc/images/coreutils-graph.dot               \
   doc/images/coreutils-bag-graph.dot           \
-  doc/images/service-graph.dot
+  doc/images/service-graph.dot                 \
+  doc/images/dmd-graph.dot
 
 DOT_VECTOR_GRAPHICS =                          \
   $(DOT_FILES:%.dot=%.eps)                     \
diff --git a/doc/guix.texi b/doc/guix.texi
index 0e0e507..fd0adfd 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -7004,6 +7004,12 @@ $ guix system extension-graph @var{file} | dot -Tpdf > 
services.pdf
 
 produces a PDF file showing the extension relations among services.
 
address@hidden
address@hidden dmd-graph
+Emit in Dot/Graphviz format to standard output the @dfn{dependency
+graph} of dmd services of the operating system defined in @var{file}.
address@hidden Services}, for more information and for an example graph.
+
 @end table
 
 
@@ -7332,10 +7338,23 @@ setuid-root programs on the system (@pxref{Setuid 
Programs}).
 The @code{(gnu services dmd)} provides a way to define services managed
 by address@hidden, which is GuixSD initialization system---the first
 process that is started when the system boots, aka. address@hidden
-(@pxref{Introduction,,, dmd, GNU dmd Manual}).  The
address@hidden represents address@hidden, of type
address@hidden; it can be extended by passing it lists of
address@hidden<dmd-service>} objects.
+(@pxref{Introduction,,, dmd, GNU dmd Manual}).
+
+Services in dmd can depend on each other.  For instance, the SSH daemon
+may need to be started after the syslog daemon has been started, which
+in turn can only happen once all the file systems have been mounted.
+The simple operating system defined earlier (@pxref{Using the
+Configuration System}) results in a service graph like this:
+
address@hidden/dmd-graph,,5in,Typical dmd service graph.}
+
+You can actually generate such a graph for any operating system
+definition using the @command{guix system dmd-graph} command
+(@pxref{system-dmd-graph, @command{guix system dmd-graph}}).
+
+The @var{%dmd-root-service} is a service object representing address@hidden,
+of type @var{dmd-root-service-type}; it can be extended by passing it
+lists of @code{<dmd-service>} objects.
 
 @deftp {Data Type} dmd-service
 The data type representing a service managed by dmd.
diff --git a/doc/images/dmd-graph.dot b/doc/images/dmd-graph.dot
new file mode 100644
index 0000000..220a2af
--- /dev/null
+++ b/doc/images/dmd-graph.dot
@@ -0,0 +1,75 @@
+digraph "Guix dmd-service" {
+  "user-file-systems" [label = "user-file-systems", shape = box, fontname = 
Helvetica];
+  "user-processes" -> "user-file-systems" [color = red];
+  "user-processes" [label = "user-processes", shape = box, fontname = 
Helvetica];
+  "nscd" -> "user-processes" [color = red];
+  "guix-daemon" -> "user-processes" [color = red];
+  "syslogd" -> "user-processes" [color = red];
+  "term-tty6" -> "user-processes" [color = red];
+  "term-tty5" -> "user-processes" [color = red];
+  "term-tty4" -> "user-processes" [color = red];
+  "term-tty3" -> "user-processes" [color = red];
+  "term-tty2" -> "user-processes" [color = red];
+  "term-tty1" -> "user-processes" [color = red];
+  "networking" -> "user-processes" [color = red];
+  "nscd" [label = "nscd", shape = box, fontname = Helvetica];
+  "guix-daemon" [label = "guix-daemon", shape = box, fontname = Helvetica];
+  "syslogd" [label = "syslogd", shape = box, fontname = Helvetica];
+  "ssh-daemon" -> "syslogd" [color = red];
+  "ssh-daemon" [label = "ssh-daemon", shape = box, fontname = Helvetica];
+  "term-tty6" [label = "term-tty6", shape = box, fontname = Helvetica];
+  "console-font-tty6" -> "term-tty6" [color = red];
+  "console-font-tty6" [label = "console-font-tty6", shape = box, fontname = 
Helvetica];
+  "term-tty5" [label = "term-tty5", shape = box, fontname = Helvetica];
+  "console-font-tty5" -> "term-tty5" [color = red];
+  "console-font-tty5" [label = "console-font-tty5", shape = box, fontname = 
Helvetica];
+  "term-tty4" [label = "term-tty4", shape = box, fontname = Helvetica];
+  "console-font-tty4" -> "term-tty4" [color = red];
+  "console-font-tty4" [label = "console-font-tty4", shape = box, fontname = 
Helvetica];
+  "term-tty3" [label = "term-tty3", shape = box, fontname = Helvetica];
+  "console-font-tty3" -> "term-tty3" [color = red];
+  "console-font-tty3" [label = "console-font-tty3", shape = box, fontname = 
Helvetica];
+  "term-tty2" [label = "term-tty2", shape = box, fontname = Helvetica];
+  "console-font-tty2" -> "term-tty2" [color = red];
+  "console-font-tty2" [label = "console-font-tty2", shape = box, fontname = 
Helvetica];
+  "term-tty1" [label = "term-tty1", shape = box, fontname = Helvetica];
+  "console-font-tty1" -> "term-tty1" [color = red];
+  "console-font-tty1" [label = "console-font-tty1", shape = box, fontname = 
Helvetica];
+  "networking" [label = "networking", shape = box, fontname = Helvetica];
+  "ssh-daemon" -> "networking" [color = red];
+  "root-file-system" [label = "root-file-system", shape = box, fontname = 
Helvetica];
+  "file-system-/run/user" -> "root-file-system" [color = red];
+  "file-system-/run/systemd" -> "root-file-system" [color = red];
+  "file-system-/gnu/store" -> "root-file-system" [color = red];
+  "file-system-/dev/shm" -> "root-file-system" [color = red];
+  "file-system-/dev/pts" -> "root-file-system" [color = red];
+  "user-processes" -> "root-file-system" [color = red];
+  "udev" -> "root-file-system" [color = red];
+  "file-system-/run/user" [label = "file-system-/run/user", shape = box, 
fontname = Helvetica];
+  "user-processes" -> "file-system-/run/user" [color = red];
+  "file-system-/run/systemd" [label = "file-system-/run/systemd", shape = box, 
fontname = Helvetica];
+  "user-processes" -> "file-system-/run/systemd" [color = red];
+  "file-system-/gnu/store" [label = "file-system-/gnu/store", shape = box, 
fontname = Helvetica];
+  "user-processes" -> "file-system-/gnu/store" [color = red];
+  "file-system-/dev/shm" [label = "file-system-/dev/shm", shape = box, 
fontname = Helvetica];
+  "user-processes" -> "file-system-/dev/shm" [color = red];
+  "file-system-/dev/pts" [label = "file-system-/dev/pts", shape = box, 
fontname = Helvetica];
+  "user-processes" -> "file-system-/dev/pts" [color = red];
+  "udev" [label = "udev", shape = box, fontname = Helvetica];
+  "term-tty6" -> "udev" [color = red];
+  "term-tty5" -> "udev" [color = red];
+  "term-tty4" -> "udev" [color = red];
+  "term-tty3" -> "udev" [color = red];
+  "term-tty2" -> "udev" [color = red];
+  "term-tty1" -> "udev" [color = red];
+  "networking" -> "udev" [color = red];
+  "host-name" [label = "host-name", shape = box, fontname = Helvetica];
+  "term-tty6" -> "host-name" [color = red];
+  "term-tty5" -> "host-name" [color = red];
+  "term-tty4" -> "host-name" [color = red];
+  "term-tty3" -> "host-name" [color = red];
+  "term-tty2" -> "host-name" [color = red];
+  "term-tty1" -> "host-name" [color = red];
+  "loopback" [label = "loopback", shape = box, fontname = Helvetica];
+
+}
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 9160969..b5da57a 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -36,6 +36,7 @@
   #:use-module (gnu system vm)
   #:use-module (gnu system grub)
   #:use-module (gnu services)
+  #:use-module (gnu services dmd)
   #:use-module (gnu packages grub)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
@@ -282,7 +283,7 @@ it atomically, and then run OS's activation script."
 
 
 ;;;
-;;; Graph.
+;;; Graphs.
 ;;;
 
 (define (service-node-label service)
@@ -311,6 +312,18 @@ list of services."
    (label service-node-label)
    (edges (lift1 (service-back-edges services) %store-monad))))
 
+(define (dmd-service-node-label service)
+  "Return a label for a node representing a <dmd-service>."
+  (string-join (map symbol->string (dmd-service-provision service))))
+
+(define (dmd-service-node-type services)
+  "Return a node type for SERVICES, a list of <dmd-service>."
+  (node-type
+   (name "dmd-service")
+   (description "the dependency graph of dmd services")
+   (identifier (lift1 dmd-service-node-label %store-monad))
+   (label dmd-service-node-label)
+   (edges (lift1 (dmd-service-back-edges services) %store-monad))))
 
 
 ;;;
@@ -410,6 +423,19 @@ building anything."
                   #:node-type (service-node-type services)
                   #:reverse-edges? #t)))
 
+(define (export-dmd-graph os port)
+  "Export the graph of dmd services of OS to PORT."
+  (let* ((services (operating-system-services os))
+         (pid1     (fold-services services
+                                  #:target-type dmd-root-service-type))
+         (dmds     (service-parameters pid1))     ;the list of <dmd-service>
+         (sinks    (filter (lambda (service)
+                             (null? (dmd-service-requirement service)))
+                           dmds)))
+    (export-graph sinks (current-output-port)
+                  #:node-type (dmd-service-node-type dmds)
+                  #:reverse-edges? #t)))
+
 
 ;;;
 ;;; Options.
@@ -435,6 +461,8 @@ Build the operating system declared in FILE according to 
ACTION.\n"))
    init             initialize a root file system to run GNU\n"))
   (display (_ "\
    extension-graph  emit the service extension graph in Dot format\n"))
+  (display (_ "\
+   dmd-graph        emit the graph of dmd services in Dot format\n"))
 
   (show-build-options-help)
   (display (_ "
@@ -543,7 +571,7 @@ Build the operating system declared in FILE according to 
ACTION.\n"))
         (let ((action (string->symbol arg)))
           (case action
             ((build vm vm-image disk-image reconfigure init
-              extension-graph)
+              extension-graph dmd-graph)
              (alist-cons 'action action result))
             (else (leave (_ "~a: unknown action~%") action))))))
 
@@ -611,6 +639,8 @@ Build the operating system declared in FILE according to 
ACTION.\n"))
           (case action
             ((extension-graph)
              (export-extension-graph os (current-output-port)))
+            ((dmd-graph)
+             (export-dmd-graph os (current-output-port)))
             (else
              (perform-action action os
                              #:dry-run? dry?