aboutsummaryrefslogtreecommitdiff
path: root/tests/graph.scm
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 /tests/graph.scm
parent12e5b26643e2269e8f30d8399886d4302c3c09d1 (diff)
downloadguix-888569161c0cb55a2700806aded7128cfe605857.tar
guix-888569161c0cb55a2700806aded7128cfe605857.tar.gz
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 'tests/graph.scm')
-rw-r--r--tests/graph.scm193
1 files changed, 193 insertions, 0 deletions
diff --git a/tests/graph.scm b/tests/graph.scm
new file mode 100644
index 0000000000..f454b06351
--- /dev/null
+++ b/tests/graph.scm
@@ -0,0 +1,193 @@
+;;; 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 (test-graph)
+ #:use-module (guix tests)
+ #:use-module (guix scripts graph)
+ #:use-module (guix packages)
+ #:use-module (guix derivations)
+ #:use-module (guix store)
+ #:use-module (guix monads)
+ #:use-module (guix build-system gnu)
+ #:use-module (guix gexp)
+ #:use-module (gnu packages)
+ #:use-module (gnu packages bootstrap)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-64))
+
+(define %store
+ (open-connection-for-tests))
+
+(define (make-recording-backend)
+ "Return a <graph-backend> and a thunk that returns the recorded nodes and
+edges."
+ (let ((nodes '())
+ (edges '()))
+ (define (record-node id label port)
+ (set! nodes (cons (list id label) nodes)))
+ (define (record-edge source target port)
+ (set! edges (cons (list source target) edges)))
+ (define (return)
+ (values (reverse nodes) (reverse edges)))
+
+ (values (graph-backend (const #t) (const #t)
+ record-node record-edge)
+ return)))
+
+(define (package->tuple package)
+ "Return a tuple representing PACKAGE as produced by %PACKAGE-NODE-TYPE."
+ (list (object-address package)
+ (package-full-name package)))
+
+(define (edge->tuple source target)
+ "Likewise for an edge from SOURCE to TARGET."
+ (list (object-address source)
+ (object-address target)))
+
+
+(test-begin "graph")
+
+(test-assert "package DAG"
+ (let-values (((backend nodes+edges) (make-recording-backend)))
+ (let* ((p1 (dummy-package "p1"))
+ (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
+ (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
+ (run-with-store %store
+ (export-graph (list p3) 'port
+ #:node-type %package-node-type
+ #:backend backend))
+ ;; We should see nothing more than these 3 packages.
+ (let-values (((nodes edges) (nodes+edges)))
+ (and (equal? nodes (map package->tuple (list p3 p2 p1)))
+ (equal? edges
+ (map edge->tuple
+ (list p3 p3 p2)
+ (list p2 p1 p1))))))))
+
+(test-assert "bag-emerged DAG"
+ (let-values (((backend nodes+edges) (make-recording-backend)))
+ (let ((p (dummy-package "p"))
+ (implicit (map (match-lambda
+ ((label package) package))
+ (standard-packages))))
+ (run-with-store %store
+ (export-graph (list p) 'port
+ #:node-type %bag-emerged-node-type
+ #:backend backend))
+ ;; We should see exactly P and IMPLICIT, with one edge from P to each
+ ;; element of IMPLICIT.
+ (let-values (((nodes edges) (nodes+edges)))
+ (and (equal? (match nodes
+ (((labels names) ...)
+ names))
+ (map package-full-name (cons p implicit)))
+ (equal? (match edges
+ (((sources destinations) ...)
+ (zip (map store-path-package-name sources)
+ (map store-path-package-name destinations))))
+ (map (lambda (destination)
+ (list "p-0.drv"
+ (string-append
+ (package-full-name destination)
+ ".drv")))
+ implicit)))))))
+
+(test-assert "bag DAG"
+ (let-values (((backend nodes+edges) (make-recording-backend)))
+ (let ((p (dummy-package "p")))
+ (run-with-store %store
+ (export-graph (list p) 'port
+ #:node-type %bag-node-type
+ #:backend backend))
+ ;; We should see P, its implicit inputs as well as the whole DAG, which
+ ;; should include bootstrap binaries.
+ (let-values (((nodes edges) (nodes+edges)))
+ (every (lambda (name)
+ (find (cut string=? name <>)
+ (match nodes
+ (((labels names) ...)
+ names))))
+ (match %bootstrap-inputs
+ (((labels packages) ...)
+ (map package-full-name packages))))))))
+
+(test-assert "derivation DAG"
+ (let-values (((backend nodes+edges) (make-recording-backend)))
+ (run-with-store %store
+ (mlet* %store-monad ((txt (text-file "text-file" "Hello!"))
+ (guile (package->derivation %bootstrap-guile))
+ (drv (gexp->derivation "output"
+ #~(symlink #$txt #$output)
+ #:guile-for-build
+ guile)))
+ ;; We should get at least these 3 nodes and corresponding edges.
+ (mbegin %store-monad
+ (export-graph (list drv) 'port
+ #:node-type %derivation-node-type
+ #:backend backend)
+ (let-values (((nodes edges) (nodes+edges)))
+ ;; XXX: For some reason we need to throw in some 'basename'.
+ (return (and (match nodes
+ (((ids labels) ...)
+ (let ((ids (map basename ids)))
+ (every (lambda (item)
+ (member (basename item) ids))
+ (list txt
+ (derivation-file-name drv)
+ (derivation-file-name guile))))))
+ (every (cut member <>
+ (map (lambda (edge)
+ (map basename edge))
+ edges))
+ (list (map (compose basename derivation-file-name)
+ (list drv guile))
+ (list (basename (derivation-file-name drv))
+ (basename txt))))))))))))
+
+(test-assert "reference DAG"
+ (let-values (((backend nodes+edges) (make-recording-backend)))
+ (run-with-store %store
+ (mlet* %store-monad ((txt (text-file "text-file" "Hello!"))
+ (guile (package->derivation %bootstrap-guile))
+ (drv (gexp->derivation "output"
+ #~(symlink #$txt #$output)
+ #:guile-for-build
+ guile))
+ (out -> (derivation->output-path drv)))
+ ;; We should see only OUT and TXT, with an edge from the former to the
+ ;; latter.
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (export-graph (list (derivation->output-path drv)) 'port
+ #:node-type %reference-node-type
+ #:backend backend)
+ (let-values (((nodes edges) (nodes+edges)))
+ (return
+ (and (equal? (match nodes
+ (((ids labels) ...)
+ ids))
+ (list out txt))
+ (equal? edges `((,out ,txt)))))))))))
+
+(test-end "graph")
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))