projects/guix·blob java-team · refs

518 lines · 23.9 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2015-2023 Ludovic Courtès <[email protected]>
3;;;
4;;; This file is part of GNU Guix.
5;;;
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.
10;;;
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.
15;;;
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/>.
18
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 build-system trivial)
29 #:use-module (guix gexp)
30 #:use-module (guix utils)
31 #:use-module (gnu packages)
32 #:use-module (gnu packages base)
33 #:use-module (gnu packages bootstrap)
34 #:use-module (gnu packages guile)
35 #:use-module (gnu packages libunistring)
36 #:use-module (gnu packages bootstrap)
37 #:use-module (ice-9 match)
38 #:use-module (ice-9 sandbox)
39 #:use-module (srfi srfi-1)
40 #:use-module (srfi srfi-11)
41 #:use-module (srfi srfi-26)
42 #:use-module (srfi srfi-64))
43
44(define %store
45 (open-connection-for-tests))
46
47;; Globally disable grafts because they can trigger early builds.
48(%graft? #f)
49
50(define (make-recording-backend)
51 "Return a <graph-backend> and a thunk that returns the recorded nodes and
52edges."
53 (let ((nodes '())
54 (edges '()))
55 (define (record-node id label port)
56 (set! nodes (cons (list id label) nodes)))
57 (define (record-edge source target port)
58 (set! edges (cons (list source target) edges)))
59 (define (return)
60 (values (reverse nodes) (reverse edges)))
61
62 (values (graph-backend "test" "This is the test backend."
63 (const #t) (const #t)
64 record-node record-edge)
65 return)))
66
67(define (package->tuple package)
68 "Return a tuple representing PACKAGE as produced by %PACKAGE-NODE-TYPE."
69 (list (object-address package)
70 (package-full-name package)))
71
72(define (edge->tuple source target)
73 "Likewise for an edge from SOURCE to TARGET."
74 (list (object-address source)
75 (object-address target)))
76
77
78(test-begin "graph")
79
80(test-assert "package DAG"
81 (let-values (((backend nodes+edges) (make-recording-backend)))
82 (let* ((p1 (dummy-package "p1"))
83 (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
84 (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
85 (run-with-store %store
86 (export-graph (list p3) 'port
87 #:node-type %package-node-type
88 #:backend backend))
89 ;; We should see nothing more than these 3 packages.
90 (let-values (((nodes edges) (nodes+edges)))
91 (and (equal? nodes (map package->tuple (list p3 p2 p1)))
92 (equal? edges
93 (map edge->tuple
94 (list p3 p3 p2)
95 (list p2 p1 p1))))))))
96
97(test-assert "package DAG, limited depth"
98 (let-values (((backend nodes+edges) (make-recording-backend)))
99 (let* ((p1 (dummy-package "p1"))
100 (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
101 (p3 (dummy-package "p3" (inputs `(("p1" ,p1)))))
102 (p4 (dummy-package "p4" (inputs `(("p2" ,p2) ("p3" ,p3))))))
103 (run-with-store %store
104 (export-graph (list p4) 'port
105 #:max-depth 1
106 #:node-type %package-node-type
107 #:backend backend))
108 ;; We should see nothing more than these 3 packages.
109 (let-values (((nodes edges) (nodes+edges)))
110 (and (equal? nodes (map package->tuple (list p4 p2 p3)))
111 (equal? edges
112 (map edge->tuple
113 (list p4 p4)
114 (list p2 p3))))))))
115
116(test-assert "package DAG, oops it was a cycle"
117 (let-values (((backend nodes+edges) (make-recording-backend)))
118 (letrec ((p1 (dummy-package "p1" (inputs `(("p3" ,p3)))))
119 (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
120 (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
121 (call-with-time-limit
122 600 ;; If ever this test should fail, we still want it to terminate
123 (lambda ()
124 (run-with-store %store
125 (export-graph (list p3) 'port
126 #:node-type %package-node-type
127 #:backend backend)))
128 (lambda ()
129 (run-with-store %store
130 (export-graph
131 (list (dummy-package "timeout-reached"))
132 'port
133 #:node-type %package-node-type
134 #:backend backend))))
135 ;; We should see nothing more than these 3 packages.
136 (let-values (((nodes edges) (nodes+edges)))
137 (and (equal? nodes (map package->tuple (list p3 p2 p1)))
138 (equal? edges
139 (map edge->tuple
140 (list p3 p3 p2 p1)
141 (list p2 p1 p1 p3))))))))
142
143(test-assert "reverse package DAG"
144 (let-values (((backend nodes+edges) (make-recording-backend)))
145 (run-with-store %store
146 (export-graph (list libunistring) 'port
147 #:node-type %reverse-package-node-type
148 #:backend backend))
149 ;; We should see nothing more than these 3 packages.
150 (let-values (((nodes edges) (nodes+edges)))
151 (and (member (package->tuple guile-2.0) nodes)
152 (->bool (member (edge->tuple libunistring guile-2.0) edges))))))
153
154(test-assert "bag-emerged DAG"
155 (let-values (((backend nodes+edges) (make-recording-backend)))
156 (let* ((o (dummy-origin (method (lambda _
157 (text-file "foo" "bar")))))
158 (p (dummy-package "p" (source o)))
159 (implicit (map (match-lambda
160 ((label package) package)
161 ((label package output) package))
162 (standard-packages))))
163 (run-with-store %store
164 (export-graph (list p) 'port
165 #:node-type %bag-emerged-node-type
166 #:backend backend))
167 ;; We should see exactly P and IMPLICIT, with one edge from P to each
168 ;; element of IMPLICIT. O must not appear among NODES. Note: IMPLICIT
169 ;; contains "glibc" twice, once for "out" and a second time for
170 ;; "static", hence the 'delete-duplicates' call below.
171 (let-values (((nodes edges) (nodes+edges)))
172 (and (equal? (match nodes
173 (((labels names) ...)
174 names))
175 (map package-full-name
176 (cons p (delete-duplicates implicit))))
177 (equal? (match edges
178 (((sources destinations) ...)
179 (zip (map store-path-package-name sources)
180 (map store-path-package-name destinations))))
181 (map (lambda (destination)
182 (list "p-0.drv"
183 (string-append
184 (package-full-name destination "-")
185 ".drv")))
186 implicit)))))))
187
188(test-assert "bag DAG" ;a big town in Iraq
189 (let-values (((backend nodes+edges) (make-recording-backend)))
190 (let ((p (dummy-package "p")))
191 (run-with-store %store
192 (export-graph (list p) 'port
193 #:node-type %bag-node-type
194 #:backend backend))
195 ;; We should see P, its implicit inputs as well as the whole DAG, which
196 ;; should include bootstrap binaries.
197 (let-values (((nodes edges) (nodes+edges)))
198 (every (lambda (name)
199 (find (cut string=? name <>)
200 (match nodes
201 (((labels names) ...)
202 names))))
203 (match (%bootstrap-inputs)
204 (((labels packages) ...)
205 (map package-full-name (filter package? packages)))))))))
206
207(test-assert "bag DAG, including origins"
208 (let-values (((backend nodes+edges) (make-recording-backend)))
209 (let* ((m (lambda* (uri hash-type hash name #:key system)
210 (text-file "foo-1.2.3.tar.gz" "This is a fake!")))
211 (o (origin
212 (method m) (uri "the-uri")
213 (sha256
214 (base32
215 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))))
216 (p (dummy-package "p" (source o))))
217 (run-with-store %store
218 (export-graph (list p) 'port
219 #:node-type %bag-with-origins-node-type
220 #:backend backend))
221 ;; We should see O among the nodes, with an edge coming from P.
222 (let-values (((nodes edges) (nodes+edges)))
223 (run-with-store %store
224 (mlet %store-monad ((o* (lower-object o))
225 (p* (lower-object p))
226 (g (lower-object (default-guile))))
227 (return
228 (and (find (match-lambda
229 ((file "the-uri") #t)
230 (_ #f))
231 nodes)
232 (find (match-lambda
233 ((source target)
234 (and (string=? source (derivation-file-name p*))
235 (string=? target o*))))
236 edges)
237
238 ;; There must also be an edge from O to G.
239 (find (match-lambda
240 ((source target)
241 (and (string=? source o*)
242 (string=? target (derivation-file-name g)))))
243 edges)))))))))
244
245(test-assert "reverse bag DAG"
246 (let-values (((dune camomile utop)
247 (values (specification->package "dune")
248 (specification->package "ocaml-camomile")
249 (specification->package "ocaml-utop")))
250 ((backend nodes+edges) (make-recording-backend)))
251 (run-with-store %store
252 (export-graph (list dune) 'port
253 #:node-type %reverse-bag-node-type
254 #:backend backend))
255
256 (run-with-store %store
257 (mlet %store-monad ((dune-drv (package->derivation dune))
258 (camomile-drv (package->derivation camomile))
259 (utop-drv (package->derivation utop)))
260 ;; CAMOMILE uses 'dune-build-system' so DUNE is a direct dependency.
261 ;; UTOP is much higher in the stack but it should be there.
262 (let-values (((nodes edges) (nodes+edges)))
263 (return
264 (and (member `(,(derivation-file-name camomile-drv)
265 ,(package-full-name camomile))
266 nodes)
267 (->bool (member (map derivation-file-name
268 (list dune-drv utop-drv))
269 edges)))))))))
270
271(test-assert "derivation DAG"
272 (let-values (((backend nodes+edges) (make-recording-backend)))
273 (run-with-store %store
274 (mlet* %store-monad ((txt (text-file "text-file" "Hello!"))
275 (guile (package->derivation %bootstrap-guile))
276 (drv (gexp->derivation "output"
277 #~(symlink #$txt #$output)
278 #:guile-for-build
279 guile)))
280 ;; We should get at least these 3 nodes and corresponding edges.
281 (mbegin %store-monad
282 (export-graph (list drv) 'port
283 #:node-type %derivation-node-type
284 #:backend backend)
285 (let-values (((nodes edges) (nodes+edges)))
286 ;; XXX: For some reason we need to throw in some 'basename'.
287 (return (and (match nodes
288 (((ids labels) ...)
289 (let ((ids (map basename ids)))
290 (every (lambda (item)
291 (member (basename item) ids))
292 (list txt
293 (derivation-file-name drv)
294 (derivation-file-name guile))))))
295 (every (cut member <>
296 (map (lambda (edge)
297 (map basename edge))
298 edges))
299 (list (map (compose basename derivation-file-name)
300 (list drv guile))
301 (list (basename (derivation-file-name drv))
302 (basename txt))))))))))))
303
304(test-assert "reference DAG"
305 (let-values (((backend nodes+edges) (make-recording-backend)))
306 (run-with-store %store
307 (mlet* %store-monad ((txt (text-file "text-file" "Hello!"))
308 (guile (package->derivation %bootstrap-guile))
309 (drv (gexp->derivation "output"
310 #~(symlink #$txt #$output)
311 #:guile-for-build
312 guile))
313 (out -> (derivation->output-path drv)))
314 ;; We should see only OUT and TXT, with an edge from the former to the
315 ;; latter.
316 (mbegin %store-monad
317 (built-derivations (list drv))
318 (export-graph (list (derivation->output-path drv)) 'port
319 #:node-type %reference-node-type
320 #:backend backend)
321 (let-values (((nodes edges) (nodes+edges)))
322 (return
323 (and (equal? (match nodes
324 (((ids labels) ...)
325 ids))
326 (list out txt))
327 (equal? edges `((,out ,txt)))))))))))
328
329(test-assert "referrer DAG"
330 (let-values (((backend nodes+edges) (make-recording-backend)))
331 (run-with-store %store
332 (mlet* %store-monad ((txt (text-file "referrer-node" (random-text)))
333 (drv (gexp->derivation "referrer"
334 #~(symlink #$txt #$output)))
335 (out -> (derivation->output-path drv)))
336 ;; We should see only TXT and OUT, with an edge from the former to the
337 ;; latter.
338 (mbegin %store-monad
339 (built-derivations (list drv))
340 (export-graph (list txt) 'port
341 #:node-type %referrer-node-type
342 #:backend backend)
343 (let-values (((nodes edges) (nodes+edges)))
344 (return
345 (and (equal? (match nodes
346 (((ids labels) ...)
347 ids))
348 (list txt out))
349 (equal? edges `((,txt ,out)))))))))))
350
351(test-assert "module graph"
352 (let-values (((backend nodes+edges) (make-recording-backend)))
353 (run-with-store %store
354 (export-graph '((gnu packages guile)) 'port
355 #:node-type %module-node-type
356 #:backend backend))
357
358 (let-values (((nodes edges) (nodes+edges)))
359 (and (member '(gnu packages guile)
360 (match nodes
361 (((ids labels) ...) ids)))
362 (->bool (and (member (list '(gnu packages guile)
363 '(gnu packages libunistring))
364 edges)
365 (member (list '(gnu packages guile)
366 '(gnu packages bdw-gc))
367 edges)))))))
368
369(test-assert "node-edges"
370 (run-with-store %store
371 (let ((packages (fold-packages cons '())))
372 (mlet %store-monad ((edges (node-edges %package-node-type packages)))
373 (return (and (null? (edges hello))
374 (lset= eq?
375 (edges guile-2.0)
376 (match (package-direct-inputs guile-2.0)
377 (((labels packages _ ...) ...)
378 packages)))))))))
379
380(test-equal "node-transitive-edges + node-back-edges"
381 '()
382 (run-with-store %store
383 (let ((packages (fold-packages cons '()))
384 (bootstrap? (lambda (package)
385 (string-contains
386 (location-file (package-location package))
387 "bootstrap.scm")))
388 (trivial? (lambda (package)
389 (eq? (package-build-system package)
390 trivial-build-system)))
391 (system-specific? (lambda (package)
392 (memq #:system (package-arguments package)))))
393 (mlet %store-monad ((edges (node-back-edges %bag-node-type packages)))
394 (let* ((glibc (canonical-package glibc))
395 (dependents (node-transitive-edges (list glibc) edges))
396 (diff (lset-difference eq? packages dependents)))
397 ;; All the packages depend on libc, except bootstrap packages, some
398 ;; packages that use TRIVIAL-BUILD-SYSTEM, and some that target a
399 ;; specific system and thus may depend on a different libc package
400 ;; object.
401 (return (remove (lambda (package)
402 (or (trivial? package)
403 (bootstrap? package)
404 (system-specific? package)))
405 diff)))))))
406
407(test-assert "node-transitive-edges, no duplicates"
408 (run-with-store %store
409 (let* ((p0 (dummy-package "p0"))
410 (p1a (dummy-package "p1a" (inputs `(("p0" ,p0)))))
411 (p1b (dummy-package "p1b" (inputs `(("p0" ,p0)))))
412 (p2 (dummy-package "p2" (inputs `(("p1a" ,p1a) ("p1b" ,p1b))))))
413 (mlet %store-monad ((edges (node-edges %package-node-type
414 (list p2 p1a p1b p0))))
415 (return (lset= eq? (node-transitive-edges (list p2) edges)
416 (list p1a p1b p0)))))))
417
418(test-assert "node-transitive-edges, references"
419 (run-with-store %store
420 (mlet* %store-monad ((d0 (package->derivation %bootstrap-guile))
421 (d1 (gexp->derivation "d1"
422 #~(begin
423 (mkdir #$output)
424 (symlink #$%bootstrap-guile
425 (string-append
426 #$output "/l")))))
427 (d2 (gexp->derivation "d2"
428 #~(begin
429 (mkdir #$output)
430 (symlink #$d1
431 (string-append
432 #$output "/l")))))
433 (_ (built-derivations (list d2)))
434 (->node -> (node-type-convert %reference-node-type))
435 (o2 (->node (derivation->output-path d2)))
436 (o1 (->node (derivation->output-path d1)))
437 (o0 (->node (derivation->output-path d0)))
438 (edges (node-edges %reference-node-type
439 (append o0 o1 o2)))
440 (reqs ((store-lift requisites) o2)))
441 (return (lset= string=?
442 (append o2 (node-transitive-edges o2 edges)) reqs)))))
443
444(test-equal "node-reachable-count"
445 '(3 3)
446 (run-with-store %store
447 (let* ((p0 (dummy-package "p0"))
448 (p1a (dummy-package "p1a" (inputs `(("p0" ,p0)))))
449 (p1b (dummy-package "p1b" (inputs `(("p0" ,p0)))))
450 (p2 (dummy-package "p2" (inputs `(("p1a" ,p1a) ("p1b" ,p1b))))))
451 (mlet* %store-monad ((all -> (list p2 p1a p1b p0))
452 (edges (node-edges %package-node-type all))
453 (back (node-back-edges %package-node-type all)))
454 (return (list (node-reachable-count (list p2) edges)
455 (node-reachable-count (list p0) back)))))))
456
457(test-equal "shortest-path, packages + derivations"
458 '(("p5" "p4" "p1" "p0")
459 ("p3" "p2" "p1" "p0")
460 #f
461 ("p5-0.drv" "p4-0.drv" "p1-0.drv" "p0-0.drv"))
462 (run-with-store %store
463 (let* ((p0 (dummy-package "p0"))
464 (p1 (dummy-package "p1" (inputs `(("p0" ,p0)))))
465 (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
466 (p3 (dummy-package "p3" (inputs `(("p2" ,p2)))))
467 (p4 (dummy-package "p4" (inputs `(("p1" ,p1)))))
468 (p5 (dummy-package "p5" (inputs `(("p4" ,p4) ("p3" ,p3))))))
469 (mlet* %store-monad ((path1 (shortest-path p5 p0 %package-node-type))
470 (path2 (shortest-path p3 p0 %package-node-type))
471 (nope (shortest-path p3 p4 %package-node-type))
472 (drv5 (package->derivation p5))
473 (drv0 (package->derivation p0))
474 (path3 (shortest-path drv5 drv0
475 %derivation-node-type)))
476 (return (append (map (lambda (path)
477 (and path (map package-name path)))
478 (list path1 path2 nope))
479 (list (map (node-type-label %derivation-node-type)
480 path3))))))))
481
482(test-equal "shortest-path, reverse packages"
483 '("libffi" "guile" "guile-json")
484 (run-with-store %store
485 (mlet %store-monad ((path (shortest-path (specification->package "libffi")
486 guile-json-1
487 %reverse-package-node-type)))
488 (return (map package-name path)))))
489
490(test-equal "shortest-path, references"
491 `(("d2" "d1" ,(package-full-name %bootstrap-guile "-"))
492 (,(package-full-name %bootstrap-guile "-") "d1" "d2"))
493 (run-with-store %store
494 (mlet* %store-monad ((d0 (package->derivation %bootstrap-guile))
495 (d1 (gexp->derivation "d1"
496 #~(begin
497 (mkdir #$output)
498 (symlink #$%bootstrap-guile
499 (string-append
500 #$output "/l")))))
501 (d2 (gexp->derivation "d2"
502 #~(begin
503 (mkdir #$output)
504 (symlink #$d1
505 (string-append
506 #$output "/l")))))
507 (_ (built-derivations (list d2)))
508 (->node -> (node-type-convert %reference-node-type))
509 (o2 (->node (derivation->output-path d2)))
510 (o0 (->node (derivation->output-path d0)))
511 (path (shortest-path (first o2) (first o0)
512 %reference-node-type))
513 (rpath (shortest-path (first o0) (first o2)
514 %referrer-node-type)))
515 (return (list (map (node-type-label %reference-node-type) path)
516 (map (node-type-label %referrer-node-type) rpath))))))
517
518(test-end "graph")