| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
| 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 grafts) |
| 28 | #:use-module (guix build-system gnu) |
| 29 | #:use-module (guix build-system trivial) |
| 30 | #:use-module (guix gexp) |
| 31 | #:use-module (guix utils) |
| 32 | #:use-module (gnu packages) |
| 33 | #:use-module (gnu packages base) |
| 34 | #:use-module (gnu packages bootstrap) |
| 35 | #:use-module (gnu packages guile) |
| 36 | #:use-module (gnu packages libunistring) |
| 37 | #:use-module (gnu packages bootstrap) |
| 38 | #:use-module (ice-9 match) |
| 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 |
| 52 | edges." |
| 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 | \f |
| 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 "reverse package DAG" |
| 98 | (let-values (((backend nodes+edges) (make-recording-backend))) |
| 99 | (run-with-store %store |
| 100 | (export-graph (list libunistring) 'port |
| 101 | #:node-type %reverse-package-node-type |
| 102 | #:backend backend)) |
| 103 | ;; We should see nothing more than these 3 packages. |
| 104 | (let-values (((nodes edges) (nodes+edges))) |
| 105 | (and (member (package->tuple guile-2.0) nodes) |
| 106 | (->bool (member (edge->tuple libunistring guile-2.0) edges)))))) |
| 107 | |
| 108 | (test-assert "bag-emerged DAG" |
| 109 | (let-values (((backend nodes+edges) (make-recording-backend))) |
| 110 | (let* ((o (dummy-origin (method (lambda _ |
| 111 | (text-file "foo" "bar"))))) |
| 112 | (p (dummy-package "p" (source o))) |
| 113 | (implicit (map (match-lambda |
| 114 | ((label package) package) |
| 115 | ((label package output) package)) |
| 116 | (standard-packages)))) |
| 117 | (run-with-store %store |
| 118 | (export-graph (list p) 'port |
| 119 | #:node-type %bag-emerged-node-type |
| 120 | #:backend backend)) |
| 121 | ;; We should see exactly P and IMPLICIT, with one edge from P to each |
| 122 | ;; element of IMPLICIT. O must not appear among NODES. Note: IMPLICIT |
| 123 | ;; contains "glibc" twice, once for "out" and a second time for |
| 124 | ;; "static", hence the 'delete-duplicates' call below. |
| 125 | (let-values (((nodes edges) (nodes+edges))) |
| 126 | (and (equal? (match nodes |
| 127 | (((labels names) ...) |
| 128 | names)) |
| 129 | (map package-full-name |
| 130 | (cons p (delete-duplicates implicit)))) |
| 131 | (equal? (match edges |
| 132 | (((sources destinations) ...) |
| 133 | (zip (map store-path-package-name sources) |
| 134 | (map store-path-package-name destinations)))) |
| 135 | (map (lambda (destination) |
| 136 | (list "p-0.drv" |
| 137 | (string-append |
| 138 | (package-full-name destination "-") |
| 139 | ".drv"))) |
| 140 | implicit))))))) |
| 141 | |
| 142 | (test-assert "bag DAG" ;a big town in Iraq |
| 143 | (let-values (((backend nodes+edges) (make-recording-backend))) |
| 144 | (let ((p (dummy-package "p"))) |
| 145 | (run-with-store %store |
| 146 | (export-graph (list p) 'port |
| 147 | #:node-type %bag-node-type |
| 148 | #:backend backend)) |
| 149 | ;; We should see P, its implicit inputs as well as the whole DAG, which |
| 150 | ;; should include bootstrap binaries. |
| 151 | (let-values (((nodes edges) (nodes+edges))) |
| 152 | (every (lambda (name) |
| 153 | (find (cut string=? name <>) |
| 154 | (match nodes |
| 155 | (((labels names) ...) |
| 156 | names)))) |
| 157 | (match (%bootstrap-inputs) |
| 158 | (((labels packages) ...) |
| 159 | (map package-full-name (filter package? packages))))))))) |
| 160 | |
| 161 | (test-assert "bag DAG, including origins" |
| 162 | (let-values (((backend nodes+edges) (make-recording-backend))) |
| 163 | (let* ((m (lambda* (uri hash-type hash name #:key system) |
| 164 | (text-file "foo-1.2.3.tar.gz" "This is a fake!"))) |
| 165 | (o (origin |
| 166 | (method m) (uri "the-uri") |
| 167 | (sha256 |
| 168 | (base32 |
| 169 | "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))) |
| 170 | (p (dummy-package "p" (source o)))) |
| 171 | (run-with-store %store |
| 172 | (export-graph (list p) 'port |
| 173 | #:node-type %bag-with-origins-node-type |
| 174 | #:backend backend)) |
| 175 | ;; We should see O among the nodes, with an edge coming from P. |
| 176 | (let-values (((nodes edges) (nodes+edges))) |
| 177 | (run-with-store %store |
| 178 | (mlet %store-monad ((o* (lower-object o)) |
| 179 | (p* (lower-object p)) |
| 180 | (g (lower-object (default-guile)))) |
| 181 | (return |
| 182 | (and (find (match-lambda |
| 183 | ((file "the-uri") #t) |
| 184 | (_ #f)) |
| 185 | nodes) |
| 186 | (find (match-lambda |
| 187 | ((source target) |
| 188 | (and (string=? source (derivation-file-name p*)) |
| 189 | (string=? target o*)))) |
| 190 | edges) |
| 191 | |
| 192 | ;; There must also be an edge from O to G. |
| 193 | (find (match-lambda |
| 194 | ((source target) |
| 195 | (and (string=? source o*) |
| 196 | (string=? target (derivation-file-name g))))) |
| 197 | edges))))))))) |
| 198 | |
| 199 | (test-assert "reverse bag DAG" |
| 200 | (let-values (((dune bap ocaml-base) |
| 201 | (values (specification->package "dune") |
| 202 | (specification->package "bap") |
| 203 | (specification->package "ocaml4.07-base"))) |
| 204 | ((backend nodes+edges) (make-recording-backend))) |
| 205 | (run-with-store %store |
| 206 | (export-graph (list dune) 'port |
| 207 | #:node-type %reverse-bag-node-type |
| 208 | #:backend backend)) |
| 209 | |
| 210 | (run-with-store %store |
| 211 | (mlet %store-monad ((dune-drv (package->derivation dune)) |
| 212 | (bap-drv (package->derivation bap)) |
| 213 | (ocaml-base-drv (package->derivation ocaml-base))) |
| 214 | ;; OCAML-BASE uses 'dune-build-system' so DUNE is a direct dependency. |
| 215 | ;; BAP is much higher in the stack but it should be there. |
| 216 | (let-values (((nodes edges) (nodes+edges))) |
| 217 | (return |
| 218 | (and (member `(,(derivation-file-name bap-drv) |
| 219 | ,(package-full-name bap)) |
| 220 | nodes) |
| 221 | (->bool (member (map derivation-file-name |
| 222 | (list dune-drv ocaml-base-drv)) |
| 223 | edges))))))))) |
| 224 | |
| 225 | (test-assert "derivation DAG" |
| 226 | (let-values (((backend nodes+edges) (make-recording-backend))) |
| 227 | (run-with-store %store |
| 228 | (mlet* %store-monad ((txt (text-file "text-file" "Hello!")) |
| 229 | (guile (package->derivation %bootstrap-guile)) |
| 230 | (drv (gexp->derivation "output" |
| 231 | #~(symlink #$txt #$output) |
| 232 | #:guile-for-build |
| 233 | guile))) |
| 234 | ;; We should get at least these 3 nodes and corresponding edges. |
| 235 | (mbegin %store-monad |
| 236 | (export-graph (list drv) 'port |
| 237 | #:node-type %derivation-node-type |
| 238 | #:backend backend) |
| 239 | (let-values (((nodes edges) (nodes+edges))) |
| 240 | ;; XXX: For some reason we need to throw in some 'basename'. |
| 241 | (return (and (match nodes |
| 242 | (((ids labels) ...) |
| 243 | (let ((ids (map basename ids))) |
| 244 | (every (lambda (item) |
| 245 | (member (basename item) ids)) |
| 246 | (list txt |
| 247 | (derivation-file-name drv) |
| 248 | (derivation-file-name guile)))))) |
| 249 | (every (cut member <> |
| 250 | (map (lambda (edge) |
| 251 | (map basename edge)) |
| 252 | edges)) |
| 253 | (list (map (compose basename derivation-file-name) |
| 254 | (list drv guile)) |
| 255 | (list (basename (derivation-file-name drv)) |
| 256 | (basename txt)))))))))))) |
| 257 | |
| 258 | (test-assert "reference DAG" |
| 259 | (let-values (((backend nodes+edges) (make-recording-backend))) |
| 260 | (run-with-store %store |
| 261 | (mlet* %store-monad ((txt (text-file "text-file" "Hello!")) |
| 262 | (guile (package->derivation %bootstrap-guile)) |
| 263 | (drv (gexp->derivation "output" |
| 264 | #~(symlink #$txt #$output) |
| 265 | #:guile-for-build |
| 266 | guile)) |
| 267 | (out -> (derivation->output-path drv))) |
| 268 | ;; We should see only OUT and TXT, with an edge from the former to the |
| 269 | ;; latter. |
| 270 | (mbegin %store-monad |
| 271 | (built-derivations (list drv)) |
| 272 | (export-graph (list (derivation->output-path drv)) 'port |
| 273 | #:node-type %reference-node-type |
| 274 | #:backend backend) |
| 275 | (let-values (((nodes edges) (nodes+edges))) |
| 276 | (return |
| 277 | (and (equal? (match nodes |
| 278 | (((ids labels) ...) |
| 279 | ids)) |
| 280 | (list out txt)) |
| 281 | (equal? edges `((,out ,txt))))))))))) |
| 282 | |
| 283 | (test-assert "referrer DAG" |
| 284 | (let-values (((backend nodes+edges) (make-recording-backend))) |
| 285 | (run-with-store %store |
| 286 | (mlet* %store-monad ((txt (text-file "referrer-node" (random-text))) |
| 287 | (drv (gexp->derivation "referrer" |
| 288 | #~(symlink #$txt #$output))) |
| 289 | (out -> (derivation->output-path drv))) |
| 290 | ;; We should see only TXT and OUT, with an edge from the former to the |
| 291 | ;; latter. |
| 292 | (mbegin %store-monad |
| 293 | (built-derivations (list drv)) |
| 294 | (export-graph (list txt) 'port |
| 295 | #:node-type %referrer-node-type |
| 296 | #:backend backend) |
| 297 | (let-values (((nodes edges) (nodes+edges))) |
| 298 | (return |
| 299 | (and (equal? (match nodes |
| 300 | (((ids labels) ...) |
| 301 | ids)) |
| 302 | (list txt out)) |
| 303 | (equal? edges `((,txt ,out))))))))))) |
| 304 | |
| 305 | (test-assert "module graph" |
| 306 | (let-values (((backend nodes+edges) (make-recording-backend))) |
| 307 | (run-with-store %store |
| 308 | (export-graph '((gnu packages guile)) 'port |
| 309 | #:node-type %module-node-type |
| 310 | #:backend backend)) |
| 311 | |
| 312 | (let-values (((nodes edges) (nodes+edges))) |
| 313 | (and (member '(gnu packages guile) |
| 314 | (match nodes |
| 315 | (((ids labels) ...) ids))) |
| 316 | (->bool (and (member (list '(gnu packages guile) |
| 317 | '(gnu packages libunistring)) |
| 318 | edges) |
| 319 | (member (list '(gnu packages guile) |
| 320 | '(gnu packages bdw-gc)) |
| 321 | edges))))))) |
| 322 | |
| 323 | (test-assert "node-edges" |
| 324 | (run-with-store %store |
| 325 | (let ((packages (fold-packages cons '()))) |
| 326 | (mlet %store-monad ((edges (node-edges %package-node-type packages))) |
| 327 | (return (and (null? (edges hello)) |
| 328 | (lset= eq? |
| 329 | (edges guile-2.0) |
| 330 | (match (package-direct-inputs guile-2.0) |
| 331 | (((labels packages _ ...) ...) |
| 332 | packages))))))))) |
| 333 | |
| 334 | (test-assert "node-transitive-edges + node-back-edges" |
| 335 | (run-with-store %store |
| 336 | (let ((packages (fold-packages cons '())) |
| 337 | (bootstrap? (lambda (package) |
| 338 | (string-contains |
| 339 | (location-file (package-location package)) |
| 340 | "bootstrap.scm"))) |
| 341 | (trivial? (lambda (package) |
| 342 | (eq? (package-build-system package) |
| 343 | trivial-build-system)))) |
| 344 | (mlet %store-monad ((edges (node-back-edges %bag-node-type packages))) |
| 345 | (let* ((glibc (canonical-package glibc)) |
| 346 | (dependents (node-transitive-edges (list glibc) edges)) |
| 347 | (diff (lset-difference eq? packages dependents))) |
| 348 | ;; All the packages depend on libc, except bootstrap packages and |
| 349 | ;; some that use TRIVIAL-BUILD-SYSTEM. |
| 350 | (return (null? (remove (lambda (package) |
| 351 | (or (trivial? package) |
| 352 | (bootstrap? package))) |
| 353 | diff)))))))) |
| 354 | |
| 355 | (test-assert "node-transitive-edges, no duplicates" |
| 356 | (run-with-store %store |
| 357 | (let* ((p0 (dummy-package "p0")) |
| 358 | (p1a (dummy-package "p1a" (inputs `(("p0" ,p0))))) |
| 359 | (p1b (dummy-package "p1b" (inputs `(("p0" ,p0))))) |
| 360 | (p2 (dummy-package "p2" (inputs `(("p1a" ,p1a) ("p1b" ,p1b)))))) |
| 361 | (mlet %store-monad ((edges (node-edges %package-node-type |
| 362 | (list p2 p1a p1b p0)))) |
| 363 | (return (lset= eq? (node-transitive-edges (list p2) edges) |
| 364 | (list p1a p1b p0))))))) |
| 365 | |
| 366 | (test-assert "node-transitive-edges, references" |
| 367 | (run-with-store %store |
| 368 | (mlet* %store-monad ((d0 (package->derivation %bootstrap-guile)) |
| 369 | (d1 (gexp->derivation "d1" |
| 370 | #~(begin |
| 371 | (mkdir #$output) |
| 372 | (symlink #$%bootstrap-guile |
| 373 | (string-append |
| 374 | #$output "/l"))))) |
| 375 | (d2 (gexp->derivation "d2" |
| 376 | #~(begin |
| 377 | (mkdir #$output) |
| 378 | (symlink #$d1 |
| 379 | (string-append |
| 380 | #$output "/l"))))) |
| 381 | (_ (built-derivations (list d2))) |
| 382 | (->node -> (node-type-convert %reference-node-type)) |
| 383 | (o2 (->node (derivation->output-path d2))) |
| 384 | (o1 (->node (derivation->output-path d1))) |
| 385 | (o0 (->node (derivation->output-path d0))) |
| 386 | (edges (node-edges %reference-node-type |
| 387 | (append o0 o1 o2))) |
| 388 | (reqs ((store-lift requisites) o2))) |
| 389 | (return (lset= string=? |
| 390 | (append o2 (node-transitive-edges o2 edges)) reqs))))) |
| 391 | |
| 392 | (test-equal "node-reachable-count" |
| 393 | '(3 3) |
| 394 | (run-with-store %store |
| 395 | (let* ((p0 (dummy-package "p0")) |
| 396 | (p1a (dummy-package "p1a" (inputs `(("p0" ,p0))))) |
| 397 | (p1b (dummy-package "p1b" (inputs `(("p0" ,p0))))) |
| 398 | (p2 (dummy-package "p2" (inputs `(("p1a" ,p1a) ("p1b" ,p1b)))))) |
| 399 | (mlet* %store-monad ((all -> (list p2 p1a p1b p0)) |
| 400 | (edges (node-edges %package-node-type all)) |
| 401 | (back (node-back-edges %package-node-type all))) |
| 402 | (return (list (node-reachable-count (list p2) edges) |
| 403 | (node-reachable-count (list p0) back))))))) |
| 404 | |
| 405 | (test-equal "shortest-path, packages + derivations" |
| 406 | '(("p5" "p4" "p1" "p0") |
| 407 | ("p3" "p2" "p1" "p0") |
| 408 | #f |
| 409 | ("p5-0.drv" "p4-0.drv" "p1-0.drv" "p0-0.drv")) |
| 410 | (run-with-store %store |
| 411 | (let* ((p0 (dummy-package "p0")) |
| 412 | (p1 (dummy-package "p1" (inputs `(("p0" ,p0))))) |
| 413 | (p2 (dummy-package "p2" (inputs `(("p1" ,p1))))) |
| 414 | (p3 (dummy-package "p3" (inputs `(("p2" ,p2))))) |
| 415 | (p4 (dummy-package "p4" (inputs `(("p1" ,p1))))) |
| 416 | (p5 (dummy-package "p5" (inputs `(("p4" ,p4) ("p3" ,p3)))))) |
| 417 | (mlet* %store-monad ((path1 (shortest-path p5 p0 %package-node-type)) |
| 418 | (path2 (shortest-path p3 p0 %package-node-type)) |
| 419 | (nope (shortest-path p3 p4 %package-node-type)) |
| 420 | (drv5 (package->derivation p5)) |
| 421 | (drv0 (package->derivation p0)) |
| 422 | (path3 (shortest-path drv5 drv0 |
| 423 | %derivation-node-type))) |
| 424 | (return (append (map (lambda (path) |
| 425 | (and path (map package-name path))) |
| 426 | (list path1 path2 nope)) |
| 427 | (list (map (node-type-label %derivation-node-type) |
| 428 | path3)))))))) |
| 429 | |
| 430 | (test-equal "shortest-path, reverse packages" |
| 431 | '("libffi" "guile" "guile-json") |
| 432 | (run-with-store %store |
| 433 | (mlet %store-monad ((path (shortest-path (specification->package "libffi") |
| 434 | guile-json |
| 435 | %reverse-package-node-type))) |
| 436 | (return (map package-name path))))) |
| 437 | |
| 438 | (test-equal "shortest-path, references" |
| 439 | `(("d2" "d1" ,(package-full-name %bootstrap-guile "-")) |
| 440 | (,(package-full-name %bootstrap-guile "-") "d1" "d2")) |
| 441 | (run-with-store %store |
| 442 | (mlet* %store-monad ((d0 (package->derivation %bootstrap-guile)) |
| 443 | (d1 (gexp->derivation "d1" |
| 444 | #~(begin |
| 445 | (mkdir #$output) |
| 446 | (symlink #$%bootstrap-guile |
| 447 | (string-append |
| 448 | #$output "/l"))))) |
| 449 | (d2 (gexp->derivation "d2" |
| 450 | #~(begin |
| 451 | (mkdir #$output) |
| 452 | (symlink #$d1 |
| 453 | (string-append |
| 454 | #$output "/l"))))) |
| 455 | (_ (built-derivations (list d2))) |
| 456 | (->node -> (node-type-convert %reference-node-type)) |
| 457 | (o2 (->node (derivation->output-path d2))) |
| 458 | (o0 (->node (derivation->output-path d0))) |
| 459 | (path (shortest-path (first o2) (first o0) |
| 460 | %reference-node-type)) |
| 461 | (rpath (shortest-path (first o0) (first o2) |
| 462 | %referrer-node-type))) |
| 463 | (return (list (map (node-type-label %reference-node-type) path) |
| 464 | (map (node-type-label %referrer-node-type) rpath)))))) |
| 465 | |
| 466 | (test-end "graph") |