tests/graph.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016, 2017, 2018, 2019 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 guile)
  35   #:use-module (gnu packages libunistring)
  36   #:use-module (gnu packages bootstrap)
  37   #:use-module (ice-9 match)
  38   #:use-module (srfi srfi-1)
  39   #:use-module (srfi srfi-11)
  40   #:use-module (srfi srfi-26)
  41   #:use-module (srfi srfi-64))
  42
  43 (define %store
  44   (open-connection-for-tests))
  45
  46 ;; Globally disable grafts because they can trigger early builds.
  47 (%graft? #f)
  48
  49 (define (make-recording-backend)
  50   "Return a <graph-backend> and a thunk that returns the recorded nodes and
  51 edges."
  52   (let ((nodes '())
  53         (edges '()))
  54     (define (record-node id label port)
  55       (set! nodes (cons (list id label) nodes)))
  56     (define (record-edge source target port)
  57       (set! edges (cons (list source target) edges)))
  58     (define (return)
  59       (values (reverse nodes) (reverse edges)))
  60
  61     (values (graph-backend "test" "This is the test backend."
  62                            (const #t) (const #t)
  63                            record-node record-edge)
  64             return)))
  65
  66 (define (package->tuple package)
  67   "Return a tuple representing PACKAGE as produced by %PACKAGE-NODE-TYPE."
  68   (list (object-address package)
  69         (package-full-name package)))
  70
  71 (define (edge->tuple source target)
  72   "Likewise for an edge from SOURCE to TARGET."
  73   (list (object-address source)
  74         (object-address target)))
  75
  76 \f
  77 (test-begin "graph")
  78
  79 (test-assert "package DAG"
  80   (let-values (((backend nodes+edges) (make-recording-backend)))
  81     (let* ((p1 (dummy-package "p1"))
  82            (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
  83            (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
  84       (run-with-store %store
  85         (export-graph (list p3) 'port
  86                       #:node-type %package-node-type
  87                       #:backend backend))
  88       ;; We should see nothing more than these 3 packages.
  89       (let-values (((nodes edges) (nodes+edges)))
  90         (and (equal? nodes (map package->tuple (list p3 p2 p1)))
  91              (equal? edges
  92                      (map edge->tuple
  93                           (list p3 p3 p2)
  94                           (list p2 p1 p1))))))))
  95
  96 (test-assert "reverse package DAG"
  97   (let-values (((backend nodes+edges) (make-recording-backend)))
  98     (run-with-store %store
  99       (export-graph (list libunistring) 'port
 100                     #:node-type %reverse-package-node-type
 101                     #:backend backend))
 102     ;; We should see nothing more than these 3 packages.
 103     (let-values (((nodes edges) (nodes+edges)))
 104       (and (member (package->tuple guile-2.0) nodes)
 105            (->bool (member (edge->tuple libunistring guile-2.0) edges))))))
 106
 107 (test-assert "bag-emerged DAG"
 108   (let-values (((backend nodes+edges) (make-recording-backend)))
 109     (let* ((o        (dummy-origin (method (lambda _
 110                                              (text-file "foo" "bar")))))
 111            (p        (dummy-package "p" (source o)))
 112            (implicit (map (match-lambda
 113                             ((label package) package)
 114                             ((label package output) package))
 115                           (standard-packages))))
 116       (run-with-store %store
 117         (export-graph (list p) 'port
 118                       #:node-type %bag-emerged-node-type
 119                       #:backend backend))
 120       ;; We should see exactly P and IMPLICIT, with one edge from P to each
 121       ;; element of IMPLICIT.  O must not appear among NODES.  Note: IMPLICIT
 122       ;; contains "glibc" twice, once for "out" and a second time for
 123       ;; "static", hence the 'delete-duplicates' call below.
 124       (let-values (((nodes edges) (nodes+edges)))
 125         (and (equal? (match nodes
 126                        (((labels names) ...)
 127                         names))
 128                      (map package-full-name
 129                           (cons p (delete-duplicates implicit))))
 130              (equal? (match edges
 131                        (((sources destinations) ...)
 132                         (zip (map store-path-package-name sources)
 133                              (map store-path-package-name destinations))))
 134                      (map (lambda (destination)
 135                             (list "p-0.drv"
 136                                   (string-append
 137                                    (package-full-name destination "-")
 138                                    ".drv")))
 139                           implicit)))))))
 140
 141 (test-assert "bag DAG"                            ;a big town in Iraq
 142   (let-values (((backend nodes+edges) (make-recording-backend)))
 143     (let ((p (dummy-package "p")))
 144       (run-with-store %store
 145         (export-graph (list p) 'port
 146                       #:node-type %bag-node-type
 147                       #:backend backend))
 148       ;; We should see P, its implicit inputs as well as the whole DAG, which
 149       ;; should include bootstrap binaries.
 150       (let-values (((nodes edges) (nodes+edges)))
 151         (every (lambda (name)
 152                  (find (cut string=? name <>)
 153                        (match nodes
 154                          (((labels names) ...)
 155                           names))))
 156                (match %bootstrap-inputs
 157                  (((labels packages) ...)
 158                   (map package-full-name packages))))))))
 159
 160 (test-assert "bag DAG, including origins"
 161   (let-values (((backend nodes+edges) (make-recording-backend)))
 162     (let* ((m (lambda* (uri hash-type hash name #:key system)
 163                 (text-file "foo-1.2.3.tar.gz" "This is a fake!")))
 164            (o (origin (method m) (uri "the-uri") (sha256 #vu8(0 1 2))))
 165            (p (dummy-package "p" (source o))))
 166       (run-with-store %store
 167         (export-graph (list p) 'port
 168                       #:node-type %bag-with-origins-node-type
 169                       #:backend backend))
 170       ;; We should see O among the nodes, with an edge coming from P.
 171       (let-values (((nodes edges) (nodes+edges)))
 172         (run-with-store %store
 173           (mlet %store-monad ((o* (lower-object o))
 174                               (p* (lower-object p))
 175                               (g  (lower-object (default-guile))))
 176             (return
 177              (and (find (match-lambda
 178                           ((file "the-uri") #t)
 179                           (_                #f))
 180                         nodes)
 181                   (find (match-lambda
 182                           ((source target)
 183                            (and (string=? source (derivation-file-name p*))
 184                                 (string=? target o*))))
 185                         edges)
 186
 187                   ;; There must also be an edge from O to G.
 188                   (find (match-lambda
 189                           ((source target)
 190                            (and (string=? source o*)
 191                                 (string=? target (derivation-file-name g)))))
 192                         edges)))))))))
 193
 194 (test-assert "reverse bag DAG"
 195   (let-values (((dune bap ocaml-base)
 196                 (values (specification->package "dune")
 197                         (specification->package "bap")
 198                         (specification->package "ocaml-base")))
 199                ((backend nodes+edges) (make-recording-backend)))
 200     (run-with-store %store
 201       (export-graph (list dune) 'port
 202                     #:node-type %reverse-bag-node-type
 203                     #:backend backend))
 204
 205     (run-with-store %store
 206       (mlet %store-monad ((dune-drv       (package->derivation dune))
 207                           (bap-drv        (package->derivation bap))
 208                           (ocaml-base-drv (package->derivation ocaml-base)))
 209         ;; OCAML-BASE uses 'dune-build-system' so DUNE is a direct dependency.
 210         ;; BAP is much higher in the stack but it should be there.
 211         (let-values (((nodes edges) (nodes+edges)))
 212           (return
 213            (and (member `(,(derivation-file-name bap-drv)
 214                           ,(package-full-name bap))
 215                         nodes)
 216                 (->bool (member (map derivation-file-name
 217                                      (list dune-drv ocaml-base-drv))
 218                                 edges)))))))))
 219
 220 (test-assert "derivation DAG"
 221   (let-values (((backend nodes+edges) (make-recording-backend)))
 222     (run-with-store %store
 223       (mlet* %store-monad ((txt   (text-file "text-file" "Hello!"))
 224                            (guile (package->derivation %bootstrap-guile))
 225                            (drv   (gexp->derivation "output"
 226                                                     #~(symlink #$txt #$output)
 227                                                     #:guile-for-build
 228                                                     guile)))
 229         ;; We should get at least these 3 nodes and corresponding edges.
 230         (mbegin %store-monad
 231           (export-graph (list drv) 'port
 232                         #:node-type %derivation-node-type
 233                         #:backend backend)
 234           (let-values (((nodes edges) (nodes+edges)))
 235             ;; XXX: For some reason we need to throw in some 'basename'.
 236             (return (and (match nodes
 237                            (((ids labels) ...)
 238                             (let ((ids (map basename ids)))
 239                               (every (lambda (item)
 240                                        (member (basename item) ids))
 241                                      (list txt
 242                                            (derivation-file-name drv)
 243                                            (derivation-file-name guile))))))
 244                          (every (cut member <>
 245                                      (map (lambda (edge)
 246                                             (map basename edge))
 247                                           edges))
 248                                 (list (map (compose basename derivation-file-name)
 249                                            (list drv guile))
 250                                       (list (basename (derivation-file-name drv))
 251                                             (basename txt))))))))))))
 252
 253 (test-assert "reference DAG"
 254   (let-values (((backend nodes+edges) (make-recording-backend)))
 255     (run-with-store %store
 256       (mlet* %store-monad ((txt   (text-file "text-file" "Hello!"))
 257                            (guile (package->derivation %bootstrap-guile))
 258                            (drv   (gexp->derivation "output"
 259                                                     #~(symlink #$txt #$output)
 260                                                     #:guile-for-build
 261                                                     guile))
 262                            (out -> (derivation->output-path drv)))
 263         ;; We should see only OUT and TXT, with an edge from the former to the
 264         ;; latter.
 265         (mbegin %store-monad
 266           (built-derivations (list drv))
 267           (export-graph (list (derivation->output-path drv)) 'port
 268                         #:node-type %reference-node-type
 269                         #:backend backend)
 270           (let-values (((nodes edges) (nodes+edges)))
 271             (return
 272              (and (equal? (match nodes
 273                             (((ids labels) ...)
 274                              ids))
 275                           (list out txt))
 276                   (equal? edges `((,out ,txt)))))))))))
 277
 278 (test-assert "referrer DAG"
 279   (let-values (((backend nodes+edges) (make-recording-backend)))
 280     (run-with-store %store
 281       (mlet* %store-monad ((txt   (text-file "referrer-node" (random-text)))
 282                            (drv   (gexp->derivation "referrer"
 283                                                     #~(symlink #$txt #$output)))
 284                            (out -> (derivation->output-path drv)))
 285         ;; We should see only TXT and OUT, with an edge from the former to the
 286         ;; latter.
 287         (mbegin %store-monad
 288           (built-derivations (list drv))
 289           (export-graph (list txt) 'port
 290                         #:node-type %referrer-node-type
 291                         #:backend backend)
 292           (let-values (((nodes edges) (nodes+edges)))
 293             (return
 294              (and (equal? (match nodes
 295                             (((ids labels) ...)
 296                              ids))
 297                           (list txt out))
 298                   (equal? edges `((,txt ,out)))))))))))
 299
 300 (test-assert "module graph"
 301   (let-values (((backend nodes+edges) (make-recording-backend)))
 302     (run-with-store %store
 303       (export-graph '((gnu packages guile)) 'port
 304                     #:node-type %module-node-type
 305                     #:backend backend))
 306
 307     (let-values (((nodes edges) (nodes+edges)))
 308       (and (member '(gnu packages guile)
 309                    (match nodes
 310                      (((ids labels) ...) ids)))
 311            (->bool (and (member (list '(gnu packages guile)
 312                                       '(gnu packages libunistring))
 313                                 edges)
 314                         (member (list '(gnu packages guile)
 315                                       '(gnu packages bdw-gc))
 316                                 edges)))))))
 317
 318 (test-assert "node-edges"
 319   (run-with-store %store
 320     (let ((packages (fold-packages cons '())))
 321       (mlet %store-monad ((edges (node-edges %package-node-type packages)))
 322         (return (and (null? (edges hello))
 323                      (lset= eq?
 324                             (edges guile-2.0)
 325                             (match (package-direct-inputs guile-2.0)
 326                               (((labels packages _ ...) ...)
 327                                packages)))))))))
 328
 329 (test-assert "node-transitive-edges + node-back-edges"
 330   (run-with-store %store
 331     (let ((packages   (fold-packages cons '()))
 332           (bootstrap? (lambda (package)
 333                         (string-contains
 334                          (location-file (package-location package))
 335                          "bootstrap.scm")))
 336           (trivial?   (lambda (package)
 337                         (eq? (package-build-system package)
 338                              trivial-build-system))))
 339       (mlet %store-monad ((edges (node-back-edges %bag-node-type packages)))
 340         (let* ((glibc      (canonical-package glibc))
 341                (dependents (node-transitive-edges (list glibc) edges))
 342                (diff       (lset-difference eq? packages dependents)))
 343           ;; All the packages depend on libc, except bootstrap packages and
 344           ;; some that use TRIVIAL-BUILD-SYSTEM.
 345           (return (null? (remove (lambda (package)
 346                                    (or (trivial? package)
 347                                        (bootstrap? package)))
 348                                  diff))))))))
 349
 350 (test-assert "node-transitive-edges, no duplicates"
 351   (run-with-store %store
 352     (let* ((p0  (dummy-package "p0"))
 353            (p1a (dummy-package "p1a" (inputs `(("p0" ,p0)))))
 354            (p1b (dummy-package "p1b" (inputs `(("p0" ,p0)))))
 355            (p2  (dummy-package "p2" (inputs `(("p1a" ,p1a) ("p1b" ,p1b))))))
 356       (mlet %store-monad ((edges (node-edges %package-node-type
 357                                              (list p2 p1a p1b p0))))
 358         (return (lset= eq? (node-transitive-edges (list p2) edges)
 359                        (list p1a p1b p0)))))))
 360
 361 (test-equal "node-reachable-count"
 362   '(3 3)
 363   (run-with-store %store
 364     (let* ((p0  (dummy-package "p0"))
 365            (p1a (dummy-package "p1a" (inputs `(("p0" ,p0)))))
 366            (p1b (dummy-package "p1b" (inputs `(("p0" ,p0)))))
 367            (p2  (dummy-package "p2" (inputs `(("p1a" ,p1a) ("p1b" ,p1b))))))
 368       (mlet* %store-monad ((all -> (list p2 p1a p1b p0))
 369                            (edges  (node-edges %package-node-type all))
 370                            (back   (node-back-edges %package-node-type all)))
 371         (return (list (node-reachable-count (list p2) edges)
 372                       (node-reachable-count (list p0) back)))))))
 373
 374 (test-end "graph")