1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (test-graph)
20 #:use-module (guix tests)
21 #:use-module (guix graph)
22 #:use-module (guix scripts graph)
23 #:use-module (guix packages)
24 #:use-module (guix derivations)
25 #:use-module (guix store)
26 #:use-module (guix monads)
27 #:use-module (guix build-system gnu)
28 #:use-module (guix gexp)
29 #:use-module (gnu packages)
30 #:use-module (gnu packages bootstrap)
31 #:use-module (ice-9 match)
32 #:use-module (srfi srfi-1)
33 #:use-module (srfi srfi-11)
34 #:use-module (srfi srfi-26)
35 #:use-module (srfi srfi-64))
38 (open-connection-for-tests))
40 (define (make-recording-backend)
41 "Return a <graph-backend> and a thunk that returns the recorded nodes and
45 (define (record-node id label port)
46 (set! nodes (cons (list id label) nodes)))
47 (define (record-edge source target port)
48 (set! edges (cons (list source target) edges)))
50 (values (reverse nodes) (reverse edges)))
52 (values (graph-backend (const #t) (const #t)
53 record-node record-edge)
56 (define (package->tuple package)
57 "Return a tuple representing PACKAGE as produced by %PACKAGE-NODE-TYPE."
58 (list (object-address package)
59 (package-full-name package)))
61 (define (edge->tuple source target)
62 "Likewise for an edge from SOURCE to TARGET."
63 (list (object-address source)
64 (object-address target)))
69 (test-assert "package DAG"
70 (let-values (((backend nodes+edges) (make-recording-backend)))
71 (let* ((p1 (dummy-package "p1"))
72 (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
73 (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
74 (run-with-store %store
75 (export-graph (list p3) 'port
76 #:node-type %package-node-type
78 ;; We should see nothing more than these 3 packages.
79 (let-values (((nodes edges) (nodes+edges)))
80 (and (equal? nodes (map package->tuple (list p3 p2 p1)))
84 (list p2 p1 p1))))))))
86 (test-assert "bag-emerged DAG"
87 (let-values (((backend nodes+edges) (make-recording-backend)))
88 (let ((p (dummy-package "p"))
89 (implicit (map (match-lambda
90 ((label package) package))
91 (standard-packages))))
92 (run-with-store %store
93 (export-graph (list p) 'port
94 #:node-type %bag-emerged-node-type
96 ;; We should see exactly P and IMPLICIT, with one edge from P to each
97 ;; element of IMPLICIT.
98 (let-values (((nodes edges) (nodes+edges)))
99 (and (equal? (match nodes
100 (((labels names) ...)
102 (map package-full-name (cons p implicit)))
104 (((sources destinations) ...)
105 (zip (map store-path-package-name sources)
106 (map store-path-package-name destinations))))
107 (map (lambda (destination)
110 (package-full-name destination)
114 (test-assert "bag DAG"
115 (let-values (((backend nodes+edges) (make-recording-backend)))
116 (let ((p (dummy-package "p")))
117 (run-with-store %store
118 (export-graph (list p) 'port
119 #:node-type %bag-node-type
121 ;; We should see P, its implicit inputs as well as the whole DAG, which
122 ;; should include bootstrap binaries.
123 (let-values (((nodes edges) (nodes+edges)))
124 (every (lambda (name)
125 (find (cut string=? name <>)
127 (((labels names) ...)
129 (match %bootstrap-inputs
130 (((labels packages) ...)
131 (map package-full-name packages))))))))
133 (test-assert "derivation DAG"
134 (let-values (((backend nodes+edges) (make-recording-backend)))
135 (run-with-store %store
136 (mlet* %store-monad ((txt (text-file "text-file" "Hello!"))
137 (guile (package->derivation %bootstrap-guile))
138 (drv (gexp->derivation "output"
139 #~(symlink #$txt #$output)
142 ;; We should get at least these 3 nodes and corresponding edges.
144 (export-graph (list drv) 'port
145 #:node-type %derivation-node-type
147 (let-values (((nodes edges) (nodes+edges)))
148 ;; XXX: For some reason we need to throw in some 'basename'.
149 (return (and (match nodes
151 (let ((ids (map basename ids)))
152 (every (lambda (item)
153 (member (basename item) ids))
155 (derivation-file-name drv)
156 (derivation-file-name guile))))))
157 (every (cut member <>
161 (list (map (compose basename derivation-file-name)
163 (list (basename (derivation-file-name drv))
164 (basename txt))))))))))))
166 (test-assert "reference DAG"
167 (let-values (((backend nodes+edges) (make-recording-backend)))
168 (run-with-store %store
169 (mlet* %store-monad ((txt (text-file "text-file" "Hello!"))
170 (guile (package->derivation %bootstrap-guile))
171 (drv (gexp->derivation "output"
172 #~(symlink #$txt #$output)
175 (out -> (derivation->output-path drv)))
176 ;; We should see only OUT and TXT, with an edge from the former to the
179 (built-derivations (list drv))
180 (export-graph (list (derivation->output-path drv)) 'port
181 #:node-type %reference-node-type
183 (let-values (((nodes edges) (nodes+edges)))
185 (and (equal? (match nodes
189 (equal? edges `((,out ,txt)))))))))))
194 (exit (= (test-runner-fail-count (test-runner-current)) 0))