aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/graph.scm193
-rw-r--r--tests/guix-graph.sh34
2 files changed, 227 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))
diff --git a/tests/guix-graph.sh b/tests/guix-graph.sh
new file mode 100644
index 0000000000..199258a9b8
--- /dev/null
+++ b/tests/guix-graph.sh
@@ -0,0 +1,34 @@
+# 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/>.
+
+#
+# Test the 'guix graph' command-line utility.
+#
+
+guix graph --version
+
+for package in guile-bootstrap coreutils python
+do
+ for graph in package bag-emerged bag
+ do
+ guix graph -t "$graph" "$package" | grep "$package"
+ done
+done
+
+guix build guile-bootstrap
+guix graph -t references guile-bootstrap | grep guile-bootstrap
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-08 14:33:29 +0000