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.
This commit is contained in:
Ludovic Courtès 2015-10-14 15:48:14 +02:00
parent a64cd7b65f
commit d6c3267a32
2 changed files with 98 additions and 19 deletions

View File

@ -6983,6 +6983,30 @@ KVM kernel module should be loaded, and the @file{/dev/kvm} device node
must exist and be readable and writable by the user and by the daemon's
build users.
The @command{guix system} command has even more to offer! The following
sub-commands allow you to visualize how your system services relate to
each other:
@anchor{system-extension-graph}
@table @code
@item extension-graph
Emit in Dot/Graphviz format to standard output the @dfn{service
extension graph} of the operating system defined in @var{file}
(@pxref{Service Composition}, for more information on service
extensions.)
The command:
@example
$ guix system extension-graph @var{file} | dot -Tpdf > services.pdf
@end example
produces a PDF file showing the extension relations among services.
@end table
@node Defining Services
@subsection Defining Services
@ -7015,6 +7039,7 @@ collects device management rules and makes them available to the eudev
daemon; the @file{/etc} service populates the system's @file{/etc}
directory.
@cindex service extensions
GuixSD services are connected by @dfn{extensions}. For instance, the
secure shell service @emph{extends} dmd---GuixSD's initialization system,
running as PID@tie{}1---by giving it the command lines to start and stop
@ -7035,6 +7060,9 @@ as arrows, a typical system might provide something like this:
At the bottom, we see the @dfn{boot service}, which produces the boot
script that is executed at boot time from the initial RAM disk.
@xref{system-extension-graph, the @command{guix system extension-graph}
command}, for information on how to generate this representation for a
particular operating system definition.
@cindex service types
Technically, developers can define @dfn{service types} to express these

View File

@ -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