summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-08-27 00:36:41 +0200
committerLudovic Courtès <ludo@gnu.org>2015-08-27 00:49:23 +0200
commit888569161c0cb55a2700806aded7128cfe605857 (patch)
tree116f9191b62d4a09575d6e811c906f54d3828241 /guix/scripts
parent12e5b26643e2269e8f30d8399886d4302c3c09d1 (diff)
Add 'guix graph'.
* guix/scripts/graph.scm, tests/graph.scm, tests/guix-graph.sh, doc/images/coreutils-bag-graph.dot, doc/images/coreutils-graph.dot: New files. * Makefile.am (MODULES): Add guix/scripts/graph.scm. (SH_TESTS): Add tests/guix-graph.sh. (SCM_TESTS): Add tests/graph.scm. * doc.am (DOT_FILES, DOT_VECTOR_GRAPHICS): New variables. (EXTRA_DIST): Use them. (dist_infoimage_DATA): Use $(DOT_FILES). (pdf-local, info-local, ps-local): Likewise. * doc/guix.texi (Packages with Multiple Outputs): Add cross-reference to 'guix graph'. (Invoking guix gc): Likewise. (Invoking guix graph): New section.
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/graph.scm426
1 files changed, 426 insertions, 0 deletions
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
new file mode 100644
index 0000000000..475f054571
--- /dev/null
+++ b/guix/scripts/graph.scm
@@ -0,0 +1,426 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts graph)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (guix monads)
+ #:use-module (guix store)
+ #:use-module (guix gexp)
+ #:use-module (guix derivations)
+ #:use-module ((guix build-system gnu) #:select (standard-packages))
+ #:use-module (gnu packages)
+ #:use-module (guix sets)
+ #:use-module (guix records)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 match)
+ #:use-module (web uri)
+ #:export (%package-node-type
+ %bag-node-type
+ %bag-emerged-node-type
+ %derivation-node-type
+ %reference-node-type
+
+ %graphviz-backend
+ graph-backend?
+ graph-backend
+
+ export-graph
+
+ guix-graph))
+
+
+;;;
+;;; Node types.
+;;;
+
+(define-record-type* <node-type> node-type make-node-type
+ node-type?
+ (identifier node-type-identifier) ;node -> M identifier
+ (label node-type-label) ;node -> string
+ (edges node-type-edges) ;node -> M list of nodes
+ (convert node-type-convert ;package -> M list of nodes
+ (default (lift1 list %store-monad)))
+ (name node-type-name) ;string
+ (description node-type-description)) ;string
+
+
+;;;
+;;; Package DAG.
+;;;
+
+(define (uri->file-name uri)
+ "Return the 'base name' of URI or URI itself, where URI is a string."
+ (let ((path (and=> (string->uri uri) uri-path)))
+ (if path
+ (basename path)
+ uri)))
+
+(define (node-full-name thing)
+ "Return a human-readable name to denote THING, a package, origin, or file
+name."
+ (cond ((package? thing)
+ (package-full-name thing))
+ ((origin? thing)
+ (or (origin-file-name thing)
+ (match (origin-uri thing)
+ ((head . tail)
+ (uri->file-name head))
+ ((? string? uri)
+ (uri->file-name uri)))))
+ ((string? thing) ;file name
+ (or (basename thing)
+ (error "basename" thing)))
+ (else
+ (number->string (object-address thing) 16))))
+
+(define (package-node-edges package)
+ "Return the list of dependencies of PACKAGE."
+ (match (package-direct-inputs package)
+ (((labels packages . outputs) ...)
+ ;; Filter out origins and other non-package dependencies.
+ (filter package? packages))))
+
+(define %package-node-type
+ ;; Type for the traversal of package nodes.
+ (node-type
+ (name "package")
+ (description "the DAG of packages, excluding implicit inputs")
+
+ ;; We use package addresses as unique identifiers. This generally works
+ ;; well, but for generated package objects, we could end up with two
+ ;; packages that are not 'eq?', yet map to the same derivation (XXX).
+ (identifier (lift1 object-address %store-monad))
+ (label node-full-name)
+ (edges (lift1 package-node-edges %store-monad))))
+
+
+;;;
+;;; Package DAG using bags.
+;;;
+
+(define (bag-node-identifier thing)
+ "Return a unique identifier for THING, which may be a package, origin, or a
+file name."
+ ;; If THING is a file name (a string), we just return it; if it's a package
+ ;; or origin, we return its address. That gives us the object graph, but
+ ;; that may differ from the derivation graph (for instance,
+ ;; 'package-with-bootstrap-guile' generates fresh package objects, and
+ ;; several packages that are not 'eq?' may actually map to the same
+ ;; derivation.) Thus, we lower THING and use its derivation file name as a
+ ;; unique identifier.
+ (with-monad %store-monad
+ (if (string? thing)
+ (return thing)
+ (mlet %store-monad ((low (lower-object thing)))
+ (return (if (derivation? low)
+ (derivation-file-name low)
+ low))))))
+
+(define (bag-node-edges thing)
+ "Return the list of dependencies of THING, a package or origin, etc."
+ (if (package? thing)
+ (match (bag-direct-inputs (package->bag thing))
+ (((labels things . outputs) ...)
+ (filter-map (match-lambda
+ ((? package? p) p)
+ ;; XXX: Here we choose to filter out origins, files,
+ ;; etc. Replace "#f" with "x" to reinstate them.
+ (x #f))
+ things)))
+ '()))
+
+(define %bag-node-type
+ ;; Type for the traversal of package nodes via the "bag" representation,
+ ;; which includes implicit inputs.
+ (node-type
+ (name "bag")
+ (description "the DAG of packages, including implicit inputs")
+ (identifier bag-node-identifier)
+ (label node-full-name)
+ (edges (lift1 bag-node-edges %store-monad))))
+
+(define standard-package-set
+ (memoize
+ (lambda ()
+ "Return the set of standard packages provided by GNU-BUILD-SYSTEM."
+ (match (standard-packages)
+ (((labels packages . output) ...)
+ (list->setq packages))))))
+
+(define (bag-node-edges-sans-bootstrap thing)
+ "Like 'bag-node-edges', but pretend that the standard packages of
+GNU-BUILD-SYSTEM have zero dependencies."
+ (if (set-contains? (standard-package-set) thing)
+ '()
+ (bag-node-edges thing)))
+
+(define %bag-emerged-node-type
+ ;; Like %BAG-NODE-TYPE, but without the bootstrap subset of the DAG.
+ (node-type
+ (name "bag-emerged")
+ (description "same as 'bag', but without the bootstrap nodes")
+ (identifier bag-node-identifier)
+ (label node-full-name)
+ (edges (lift1 bag-node-edges-sans-bootstrap %store-monad))))
+
+
+;;;
+;;; Derivation DAG.
+;;;
+
+(define (file->derivation file)
+ "Read the derivation from FILE and return it."
+ (call-with-input-file file read-derivation))
+
+(define (derivation-dependencies obj)
+ "Return the <derivation> objects and store items corresponding to the
+dependencies of OBJ, a <derivation> or store item."
+ (if (derivation? obj)
+ (append (map (compose file->derivation derivation-input-path)
+ (derivation-inputs obj))
+ (derivation-sources obj))
+ '()))
+
+(define (derivation-node-identifier node)
+ "Return a unique identifier for NODE, which may be either a <derivation> or
+a plain store file."
+ (if (derivation? node)
+ (derivation-file-name node)
+ node))
+
+(define (derivation-node-label node)
+ "Return a label for NODE, a <derivation> object or plain store item."
+ (store-path-package-name (match node
+ ((? derivation? drv)
+ (derivation-file-name drv))
+ ((? string? file)
+ file))))
+
+(define %derivation-node-type
+ ;; DAG of derivations. Very accurate, very detailed, but usually too much
+ ;; detailed.
+ (node-type
+ (name "derivation")
+ (description "the DAG of derivations")
+ (convert (lambda (package)
+ (with-monad %store-monad
+ (>>= (package->derivation package)
+ (lift1 list %store-monad)))))
+ (identifier (lift1 derivation-node-identifier %store-monad))
+ (label derivation-node-label)
+ (edges (lift1 derivation-dependencies %store-monad))))
+
+
+;;;
+;;; DAG of residual references (aka. run-time dependencies).
+;;;
+
+(define (references* item)
+ "Return as a monadic value the references of ITEM, based either on the
+information available in the local store or using information about
+substitutes."
+ (lambda (store)
+ (guard (c ((nix-protocol-error? c)
+ (match (substitutable-path-info store (list item))
+ ((info)
+ (values (substitutable-references info) store))
+ (()
+ (leave (_ "references for '~a' are not known~%")
+ item)))))
+ (values (references store item) store))))
+
+(define %reference-node-type
+ (node-type
+ (name "references")
+ (description "the DAG of run-time dependencies (store references)")
+ (convert (lambda (package)
+ ;; Return the output file names of PACKAGE.
+ (mlet %store-monad ((drv (package->derivation package)))
+ (return (match (derivation->output-paths drv)
+ (((_ . file-names) ...)
+ file-names))))))
+ (identifier (lift1 identity %store-monad))
+ (label store-path-package-name)
+ (edges references*)))
+
+
+;;;
+;;; List of node types.
+;;;
+
+(define %node-types
+ ;; List of all the node types.
+ (list %package-node-type
+ %bag-node-type
+ %bag-emerged-node-type
+ %derivation-node-type
+ %reference-node-type))
+
+(define (lookup-node-type name)
+ "Return the node type called NAME. Raise an error if it is not found."
+ (or (find (lambda (type)
+ (string=? (node-type-name type) name))
+ %node-types)
+ (leave (_ "~a: unknown node type~%") name)))
+
+(define (list-node-types)
+ "Print the available node types along with their synopsis."
+ (display (_ "The available node types are:\n"))
+ (newline)
+ (for-each (lambda (type)
+ (format #t " - ~a: ~a~%"
+ (node-type-name type)
+ (node-type-description type)))
+ %node-types))
+
+
+;;;
+;;; Graphviz export.
+;;;
+
+(define-record-type <graph-backend>
+ (graph-backend prologue epilogue node edge)
+ graph-backend?
+ (prologue graph-backend-prologue)
+ (epilogue graph-backend-epilogue)
+ (node graph-backend-node)
+ (edge graph-backend-edge))
+
+(define (emit-prologue name port)
+ (format port "digraph \"Guix ~a\" {\n"
+ name))
+(define (emit-epilogue port)
+ (display "\n}\n" port))
+(define (emit-node id label port)
+ (format port " \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
+ id label))
+(define (emit-edge id1 id2 port)
+ (format port " \"~a\" -> \"~a\" [color = red];~%"
+ id1 id2))
+
+(define %graphviz-backend
+ (graph-backend emit-prologue emit-epilogue
+ emit-node emit-edge))
+
+(define* (export-graph sinks port
+ #:key
+ (node-type %package-node-type)
+ (backend %graphviz-backend))
+ "Write to PORT the representation of the DAG with the given SINKS, using the
+given BACKEND. Use NODE-TYPE to traverse the DAG."
+ (match backend
+ (($ <graph-backend> emit-prologue emit-epilogue emit-node emit-edge)
+ (emit-prologue (node-type-name node-type) port)
+
+ (match node-type
+ (($ <node-type> node-identifier node-label node-edges)
+ (let loop ((nodes sinks)
+ (visited (set)))
+ (match nodes
+ (()
+ (with-monad %store-monad
+ (emit-epilogue port)
+ (store-return #t)))
+ ((head . tail)
+ (mlet %store-monad ((id (node-identifier head)))
+ (if (set-contains? visited id)
+ (loop tail visited)
+ (mlet* %store-monad ((dependencies (node-edges head))
+ (ids (mapm %store-monad
+ node-identifier
+ dependencies)))
+ (emit-node id (node-label head) port)
+ (for-each (lambda (dependency dependency-id)
+ (emit-edge id dependency-id port))
+ dependencies ids)
+ (loop (append dependencies tail)
+ (set-insert id visited)))))))))))))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %options
+ (list (option '(#\t "type") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'node-type (lookup-node-type arg)
+ result)))
+ (option '("list-types") #f #f
+ (lambda (opt name arg result)
+ (list-node-types)
+ (exit 0)))
+ (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix edit")))))
+
+(define (show-help)
+ ;; TRANSLATORS: Here 'dot' is the name of a program; it must not be
+ ;; translated.
+ (display (_ "Usage: guix graph PACKAGE...
+Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n"))
+ (display (_ "
+ -t, --type=TYPE represent nodes of the given TYPE"))
+ (display (_ "
+ --list-types list the available graph types"))
+ (newline)
+ (display (_ "
+ -h, --help display this help and exit"))
+ (display (_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %default-options
+ `((node-type . ,%package-node-type)))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-graph . args)
+ (with-error-handling
+ (let* ((opts (parse-command-line args %options
+ (list %default-options)))
+ (specs (filter-map (match-lambda
+ (('argument . spec) spec)
+ (_ #f))
+ opts))
+ (type (assoc-ref opts 'node-type))
+ (packages (map specification->package specs)))
+ (with-store store
+ (run-with-store store
+ (mlet %store-monad ((nodes (mapm %store-monad
+ (node-type-convert type)
+ packages)))
+ (export-graph (concatenate nodes)
+ (current-output-port)
+ #:node-type type))))))
+ #t)
+
+;;; graph.scm ends here