tests/graph.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015 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 build-system gnu)
  28   #:use-module (guix build-system trivial)
  29   #:use-module (guix gexp)
  30   #:use-module (guix utils)
  31   #:use-module (gnu packages)
  32   #:use-module (gnu packages base)
  33   #:use-module (gnu packages guile)
  34   #:use-module (gnu packages bootstrap)
  35   #:use-module (ice-9 match)
  36   #:use-module (srfi srfi-1)
  37   #:use-module (srfi srfi-11)
  38   #:use-module (srfi srfi-26)
  39   #:use-module (srfi srfi-64))
  40
  41 (define %store
  42   (open-connection-for-tests))
  43
  44 (define (make-recording-backend)
  45   "Return a <graph-backend> and a thunk that returns the recorded nodes and
  46 edges."
  47   (let ((nodes '())
  48         (edges '()))
  49     (define (record-node id label port)
  50       (set! nodes (cons (list id label) nodes)))
  51     (define (record-edge source target port)
  52       (set! edges (cons (list source target) edges)))
  53     (define (return)
  54       (values (reverse nodes) (reverse edges)))
  55
  56     (values (graph-backend (const #t) (const #t)
  57                            record-node record-edge)
  58             return)))
  59
  60 (define (package->tuple package)
  61   "Return a tuple representing PACKAGE as produced by %PACKAGE-NODE-TYPE."
  62   (list (object-address package)
  63         (package-full-name package)))
  64
  65 (define (edge->tuple source target)
  66   "Likewise for an edge from SOURCE to TARGET."
  67   (list (object-address source)
  68         (object-address target)))
  69
  70 \f
  71 (test-begin "graph")
  72
  73 (test-assert "package DAG"
  74   (let-values (((backend nodes+edges) (make-recording-backend)))
  75     (let* ((p1 (dummy-package "p1"))
  76            (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
  77            (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
  78       (run-with-store %store
  79         (export-graph (list p3) 'port
  80                       #:node-type %package-node-type
  81                       #:backend backend))
  82       ;; We should see nothing more than these 3 packages.
  83       (let-values (((nodes edges) (nodes+edges)))
  84         (and (equal? nodes (map package->tuple (list p3 p2 p1)))
  85              (equal? edges
  86                      (map edge->tuple
  87                           (list p3 p3 p2)
  88                           (list p2 p1 p1))))))))
  89
  90 (test-assert "bag-emerged DAG"
  91   (let-values (((backend nodes+edges) (make-recording-backend)))
  92     (let ((p        (dummy-package "p"))
  93           (implicit (map (match-lambda
  94                            ((label package) package))
  95                          (standard-packages))))
  96       (run-with-store %store
  97         (export-graph (list p) 'port
  98                       #:node-type %bag-emerged-node-type
  99                       #:backend backend))
 100       ;; We should see exactly P and IMPLICIT, with one edge from P to each
 101       ;; element of IMPLICIT.
 102       (let-values (((nodes edges) (nodes+edges)))
 103         (and (equal? (match nodes
 104                        (((labels names) ...)
 105                         names))
 106                      (map package-full-name (cons p implicit)))
 107              (equal? (match edges
 108                        (((sources destinations) ...)
 109                         (zip (map store-path-package-name sources)
 110                              (map store-path-package-name destinations))))
 111                      (map (lambda (destination)
 112                             (list "p-0.drv"
 113                                   (string-append
 114                                    (package-full-name destination)
 115                                    ".drv")))
 116                           implicit)))))))
 117
 118 (test-assert "bag DAG"                            ;a big town in Iraq
 119   (let-values (((backend nodes+edges) (make-recording-backend)))
 120     (let ((p (dummy-package "p")))
 121       (run-with-store %store
 122         (export-graph (list p) 'port
 123                       #:node-type %bag-node-type
 124                       #:backend backend))
 125       ;; We should see P, its implicit inputs as well as the whole DAG, which
 126       ;; should include bootstrap binaries.
 127       (let-values (((nodes edges) (nodes+edges)))
 128         (every (lambda (name)
 129                  (find (cut string=? name <>)
 130                        (match nodes
 131                          (((labels names) ...)
 132                           names))))
 133                (match %bootstrap-inputs
 134                  (((labels packages) ...)
 135                   (map package-full-name packages))))))))
 136
 137 (test-assert "derivation DAG"
 138   (let-values (((backend nodes+edges) (make-recording-backend)))
 139     (run-with-store %store
 140       (mlet* %store-monad ((txt   (text-file "text-file" "Hello!"))
 141                            (guile (package->derivation %bootstrap-guile))
 142                            (drv   (gexp->derivation "output"
 143                                                     #~(symlink #$txt #$output)
 144                                                     #:guile-for-build
 145                                                     guile)))
 146         ;; We should get at least these 3 nodes and corresponding edges.
 147         (mbegin %store-monad
 148           (export-graph (list drv) 'port
 149                         #:node-type %derivation-node-type
 150                         #:backend backend)
 151           (let-values (((nodes edges) (nodes+edges)))
 152             ;; XXX: For some reason we need to throw in some 'basename'.
 153             (return (and (match nodes
 154                            (((ids labels) ...)
 155                             (let ((ids (map basename ids)))
 156                               (every (lambda (item)
 157                                        (member (basename item) ids))
 158                                      (list txt
 159                                            (derivation-file-name drv)
 160                                            (derivation-file-name guile))))))
 161                          (every (cut member <>
 162                                      (map (lambda (edge)
 163                                             (map basename edge))
 164                                           edges))
 165                                 (list (map (compose basename derivation-file-name)
 166                                            (list drv guile))
 167                                       (list (basename (derivation-file-name drv))
 168                                             (basename txt))))))))))))
 169
 170 (test-assert "reference DAG"
 171   (let-values (((backend nodes+edges) (make-recording-backend)))
 172     (run-with-store %store
 173       (mlet* %store-monad ((txt   (text-file "text-file" "Hello!"))
 174                            (guile (package->derivation %bootstrap-guile))
 175                            (drv   (gexp->derivation "output"
 176                                                     #~(symlink #$txt #$output)
 177                                                     #:guile-for-build
 178                                                     guile))
 179                            (out -> (derivation->output-path drv)))
 180         ;; We should see only OUT and TXT, with an edge from the former to the
 181         ;; latter.
 182         (mbegin %store-monad
 183           (built-derivations (list drv))
 184           (export-graph (list (derivation->output-path drv)) 'port
 185                         #:node-type %reference-node-type
 186                         #:backend backend)
 187           (let-values (((nodes edges) (nodes+edges)))
 188             (return
 189              (and (equal? (match nodes
 190                             (((ids labels) ...)
 191                              ids))
 192                           (list out txt))
 193                   (equal? edges `((,out ,txt)))))))))))
 194
 195 (test-assert "node-edges"
 196   (run-with-store %store
 197     (let ((packages (fold-packages cons '())))
 198       (mlet %store-monad ((edges (node-edges %package-node-type packages)))
 199         (return (and (null? (edges grep))
 200                      (lset= eq?
 201                             (edges guile-2.0)
 202                             (match (package-direct-inputs guile-2.0)
 203                               (((labels packages _ ...) ...)
 204                                packages)))))))))
 205
 206 (test-assert "node-transitive-edges + node-back-edges"
 207   (run-with-store %store
 208     (let ((packages   (fold-packages cons '()))
 209           (bootstrap? (lambda (package)
 210                         (string-contains
 211                          (location-file (package-location package))
 212                          "bootstrap.scm")))
 213           (trivial?   (lambda (package)
 214                         (eq? (package-build-system package)
 215                              trivial-build-system))))
 216       (mlet %store-monad ((edges (node-back-edges %bag-node-type packages)))
 217         (let* ((glibc      (canonical-package glibc))
 218                (dependents (node-transitive-edges (list glibc) edges))
 219                (diff       (lset-difference eq? packages dependents)))
 220           ;; All the packages depend on libc, except bootstrap packages and
 221           ;; some that use TRIVIAL-BUILD-SYSTEM.
 222           (return (null? (remove (lambda (package)
 223                                    (or (trivial? package)
 224                                        (bootstrap? package)))
 225                                  diff))))))))
 226
 227 (test-end "graph")
 228
 229 \f
 230 (exit (= (test-runner-fail-count (test-runner-current)) 0))