From d6c3267a32ae80b5a6f780a1678710ecc958b456 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 14 Oct 2015 15:48:14 +0200
Subject: guix system: Add 'extension-graph' command.

* guix/scripts/system.scm (service-node-label, service-node-type,
  export-extension-graph): New procedures.
  (guix-system)[parse-sub-command]: Add 'extension-graph'.
  Honor it.
  (show-help): Add 'extension-graph'.
* doc/guix.texi (Invoking guix system): Document it.
  (Service Composition): Add cross-reference.
---
 guix/scripts/system.scm | 89 ++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 70 insertions(+), 19 deletions(-)

(limited to 'guix')

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 71b92dacc7..9160969b95 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -28,12 +28,14 @@
   #:use-module (guix profiles)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
+  #:use-module (guix scripts graph)
   #:use-module (guix build utils)
   #:use-module (gnu build install)
   #:use-module (gnu system)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system vm)
   #:use-module (gnu system grub)
+  #:use-module (gnu services)
   #:use-module (gnu packages grub)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
@@ -278,6 +280,38 @@ it atomically, and then run OS's activation script."
                        systems)))
     (filter-map system->grub-entry systems numbers times)))
 
+
+;;;
+;;; Graph.
+;;;
+
+(define (service-node-label service)
+  "Return a label to represent SERVICE."
+  (let ((type  (service-kind service))
+        (value (service-parameters service)))
+    (string-append (symbol->string (service-type-name type))
+                   (cond ((or (number? value) (symbol? value))
+                          (string-append " " (object->string value)))
+                         ((string? value)
+                          (string-append " " value))
+                         ((file-system? value)
+                          (string-append " " (file-system-mount-point value)))
+                         (else
+                          "")))))
+
+(define (service-node-type services)
+  "Return a node type for SERVICES.  Since <service> instances are not
+self-contained (they express dependencies on service types, not on services),
+we have to create the 'edges' procedure dynamically as a function of the full
+list of services."
+  (node-type
+   (name "service")
+   (description "the DAG of services")
+   (identifier (lift1 object-address %store-monad))
+   (label service-node-label)
+   (edges (lift1 (service-back-edges services) %store-monad))))
+
+
 
 ;;;
 ;;; Action.
@@ -366,6 +400,16 @@ building anything."
              ;; All we had to do was to build SYS.
              (return (derivation->output-path sys))))))))
 
+(define (export-extension-graph os port)
+  "Export the service extension graph of OS to PORT."
+  (let* ((services (operating-system-services os))
+         (boot     (find (lambda (service)
+                           (eq? (service-kind service) boot-service-type))
+                         services)))
+    (export-graph (list boot) (current-output-port)
+                  #:node-type (service-node-type services)
+                  #:reverse-edges? #t)))
+
 
 ;;;
 ;;; Options.
@@ -388,7 +432,9 @@ Build the operating system declared in FILE according to ACTION.\n"))
   (display (_ "\
    disk-image       build a disk image, suitable for a USB stick\n"))
   (display (_ "\
-   init             initialize a root file system to run GNU.\n"))
+   init             initialize a root file system to run GNU\n"))
+  (display (_ "\
+   extension-graph  emit the service extension graph in Dot format\n"))
 
   (show-build-options-help)
   (display (_ "
@@ -496,16 +542,17 @@ Build the operating system declared in FILE according to ACTION.\n"))
         (alist-cons 'argument arg result)
         (let ((action (string->symbol arg)))
           (case action
-            ((build vm vm-image disk-image reconfigure init)
+            ((build vm vm-image disk-image reconfigure init
+              extension-graph)
              (alist-cons 'action action result))
             (else (leave (_ "~a: unknown action~%") action))))))
 
   (define (match-pair car)
     ;; Return a procedure that matches a pair with CAR.
     (match-lambda
-     ((head . tail)
-      (and (eq? car head) tail))
-     (_ #f)))
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
 
   (define (option-arguments opts)
     ;; Extract the plain arguments from OPTS.
@@ -561,20 +608,24 @@ Build the operating system declared in FILE according to ACTION.\n"))
       (run-with-store store
         (mbegin %store-monad
           (set-guile-for-build (default-guile))
-          (perform-action action os
-                          #:dry-run? dry?
-                          #:derivations-only? (assoc-ref opts
-                                                         'derivations-only?)
-                          #:use-substitutes? (assoc-ref opts 'substitutes?)
-                          #:image-size (assoc-ref opts 'image-size)
-                          #:full-boot? (assoc-ref opts 'full-boot?)
-                          #:mappings (filter-map (match-lambda
-                                                  (('file-system-mapping . m)
-                                                   m)
-                                                  (_ #f))
-                                                 opts)
-                          #:grub? grub?
-                          #:target target #:device device))
+          (case action
+            ((extension-graph)
+             (export-extension-graph os (current-output-port)))
+            (else
+             (perform-action action os
+                             #:dry-run? dry?
+                             #:derivations-only? (assoc-ref opts
+                                                            'derivations-only?)
+                             #:use-substitutes? (assoc-ref opts 'substitutes?)
+                             #:image-size (assoc-ref opts 'image-size)
+                             #:full-boot? (assoc-ref opts 'full-boot?)
+                             #:mappings (filter-map (match-lambda
+                                                      (('file-system-mapping . m)
+                                                       m)
+                                                      (_ #f))
+                                                    opts)
+                             #:grub? grub?
+                             #:target target #:device device))))
         #:system system))))
 
 ;;; system.scm ends here
-- 
cgit v1.2.3