tests/graph.scm

   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")