tests/graph.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016, 2017, 2018 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 "derivation DAG"
 195   (let-values (((backend nodes+edges) (make-recording-backend)))
 196     (run-with-store %store
 197       (mlet* %store-monad ((txt   (text-file "text-file" "Hello!"))
 198                            (guile (package->derivation %bootstrap-guile))
 199                            (drv   (gexp->derivation "output"
 200                                                     #~(symlink #$txt #$output)
 201                                                     #:guile-for-build
 202                                                     guile)))
 203         ;; We should get at least these 3 nodes and corresponding edges.
 204         (mbegin %store-monad
 205           (export-graph (list drv) 'port
 206                         #:node-type %derivation-node-type
 207                         #:backend backend)
 208           (let-values (((nodes edges) (nodes+edges)))
 209             ;; XXX: For some reason we need to throw in some 'basename'.
 210             (return (and (match nodes
 211                            (((ids labels) ...)
 212                             (let ((ids (map basename ids)))
 213                               (every (lambda (item)
 214                                        (member (basename item) ids))
 215                                      (list txt
 216                                            (derivation-file-name drv)
 217                                            (derivation-file-name guile))))))
 218                          (every (cut member <>
 219                                      (map (lambda (edge)
 220                                             (map basename edge))
 221                                           edges))
 222                                 (list (map (compose basename derivation-file-name)
 223                                            (list drv guile))
 224                                       (list (basename (derivation-file-name drv))
 225                                             (basename txt))))))))))))
 226
 227 (test-assert "reference DAG"
 228   (let-values (((backend nodes+edges) (make-recording-backend)))
 229     (run-with-store %store
 230       (mlet* %store-monad ((txt   (text-file "text-file" "Hello!"))
 231                            (guile (package->derivation %bootstrap-guile))
 232                            (drv   (gexp->derivation "output"
 233                                                     #~(symlink #$txt #$output)
 234                                                     #:guile-for-build
 235                                                     guile))
 236                            (out -> (derivation->output-path drv)))
 237         ;; We should see only OUT and TXT, with an edge from the former to the
 238         ;; latter.
 239         (mbegin %store-monad
 240           (built-derivations (list drv))
 241           (export-graph (list (derivation->output-path drv)) 'port
 242                         #:node-type %reference-node-type
 243                         #:backend backend)
 244           (let-values (((nodes edges) (nodes+edges)))
 245             (return
 246              (and (equal? (match nodes
 247                             (((ids labels) ...)
 248                              ids))
 249                           (list out txt))
 250                   (equal? edges `((,out ,txt)))))))))))
 251
 252 (test-assert "referrer DAG"
 253   (let-values (((backend nodes+edges) (make-recording-backend)))
 254     (run-with-store %store
 255       (mlet* %store-monad ((txt   (text-file "referrer-node" (random-text)))
 256                            (drv   (gexp->derivation "referrer"
 257                                                     #~(symlink #$txt #$output)))
 258                            (out -> (derivation->output-path drv)))
 259         ;; We should see only TXT and OUT, with an edge from the former to the
 260         ;; latter.
 261         (mbegin %store-monad
 262           (built-derivations (list drv))
 263           (export-graph (list txt) 'port
 264                         #:node-type %referrer-node-type
 265                         #:backend backend)
 266           (let-values (((nodes edges) (nodes+edges)))
 267             (return
 268              (and (equal? (match nodes
 269                             (((ids labels) ...)
 270                              ids))
 271                           (list txt out))
 272                   (equal? edges `((,txt ,out)))))))))))
 273
 274 (test-assert "module graph"
 275   (let-values (((backend nodes+edges) (make-recording-backend)))
 276     (run-with-store %store
 277       (export-graph '((gnu packages guile)) 'port
 278                     #:node-type %module-node-type
 279                     #:backend backend))
 280
 281     (let-values (((nodes edges) (nodes+edges)))
 282       (and (member '(gnu packages guile)
 283                    (match nodes
 284                      (((ids labels) ...) ids)))
 285            (->bool (and (member (list '(gnu packages guile)
 286                                       '(gnu packages libunistring))
 287                                 edges)
 288                         (member (list '(gnu packages guile)
 289                                       '(gnu packages bdw-gc))
 290                                 edges)))))))
 291
 292 (test-assert "node-edges"
 293   (run-with-store %store
 294     (let ((packages (fold-packages cons '())))
 295       (mlet %store-monad ((edges (node-edges %package-node-type packages)))
 296         (return (and (null? (edges hello))
 297                      (lset= eq?
 298                             (edges guile-2.0)
 299                             (match (package-direct-inputs guile-2.0)
 300                               (((labels packages _ ...) ...)
 301                                packages)))))))))
 302
 303 (test-assert "node-transitive-edges + node-back-edges"
 304   (run-with-store %store
 305     (let ((packages   (fold-packages cons '()))
 306           (bootstrap? (lambda (package)
 307                         (string-contains
 308                          (location-file (package-location package))
 309                          "bootstrap.scm")))
 310           (trivial?   (lambda (package)
 311                         (eq? (package-build-system package)
 312                              trivial-build-system))))
 313       (mlet %store-monad ((edges (node-back-edges %bag-node-type packages)))
 314         (let* ((glibc      (canonical-package glibc))
 315                (dependents (node-transitive-edges (list glibc) edges))
 316                (diff       (lset-difference eq? packages dependents)))
 317           ;; All the packages depend on libc, except bootstrap packages and
 318           ;; some that use TRIVIAL-BUILD-SYSTEM.
 319           (return (null? (remove (lambda (package)
 320                                    (or (trivial? package)
 321                                        (bootstrap? package)))
 322                                  diff))))))))
 323
 324 (test-assert "node-transitive-edges, no duplicates"
 325   (run-with-store %store
 326     (let* ((p0  (dummy-package "p0"))
 327            (p1a (dummy-package "p1a" (inputs `(("p0" ,p0)))))
 328            (p1b (dummy-package "p1b" (inputs `(("p0" ,p0)))))
 329            (p2  (dummy-package "p2" (inputs `(("p1a" ,p1a) ("p1b" ,p1b))))))
 330       (mlet %store-monad ((edges (node-edges %package-node-type
 331                                              (list p2 p1a p1b p0))))
 332         (return (lset= eq? (node-transitive-edges (list p2) edges)
 333                        (list p1a p1b p0)))))))
 334
 335 (test-equal "node-reachable-count"
 336   '(3 3)
 337   (run-with-store %store
 338     (let* ((p0  (dummy-package "p0"))
 339            (p1a (dummy-package "p1a" (inputs `(("p0" ,p0)))))
 340            (p1b (dummy-package "p1b" (inputs `(("p0" ,p0)))))
 341            (p2  (dummy-package "p2" (inputs `(("p1a" ,p1a) ("p1b" ,p1b))))))
 342       (mlet* %store-monad ((all -> (list p2 p1a p1b p0))
 343                            (edges  (node-edges %package-node-type all))
 344                            (back   (node-back-edges %package-node-type all)))
 345         (return (list (node-reachable-count (list p2) edges)
 346                       (node-reachable-count (list p0) back)))))))
 347
 348 (test-end "graph")