tests/graph.scm

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