194 lines
8.1 KiB
Scheme
194 lines
8.1 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
|
||
;;;
|
||
;;; This file is part of GNU Guix.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (test-graph)
|
||
#:use-module (guix tests)
|
||
#:use-module (guix scripts graph)
|
||
#:use-module (guix packages)
|
||
#:use-module (guix derivations)
|
||
#:use-module (guix store)
|
||
#:use-module (guix monads)
|
||
#:use-module (guix build-system gnu)
|
||
#:use-module (guix gexp)
|
||
#:use-module (gnu packages)
|
||
#:use-module (gnu packages bootstrap)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-11)
|
||
#:use-module (srfi srfi-26)
|
||
#:use-module (srfi srfi-64))
|
||
|
||
(define %store
|
||
(open-connection-for-tests))
|
||
|
||
(define (make-recording-backend)
|
||
"Return a <graph-backend> and a thunk that returns the recorded nodes and
|
||
edges."
|
||
(let ((nodes '())
|
||
(edges '()))
|
||
(define (record-node id label port)
|
||
(set! nodes (cons (list id label) nodes)))
|
||
(define (record-edge source target port)
|
||
(set! edges (cons (list source target) edges)))
|
||
(define (return)
|
||
(values (reverse nodes) (reverse edges)))
|
||
|
||
(values (graph-backend (const #t) (const #t)
|
||
record-node record-edge)
|
||
return)))
|
||
|
||
(define (package->tuple package)
|
||
"Return a tuple representing PACKAGE as produced by %PACKAGE-NODE-TYPE."
|
||
(list (object-address package)
|
||
(package-full-name package)))
|
||
|
||
(define (edge->tuple source target)
|
||
"Likewise for an edge from SOURCE to TARGET."
|
||
(list (object-address source)
|
||
(object-address target)))
|
||
|
||
|
||
(test-begin "graph")
|
||
|
||
(test-assert "package DAG"
|
||
(let-values (((backend nodes+edges) (make-recording-backend)))
|
||
(let* ((p1 (dummy-package "p1"))
|
||
(p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
|
||
(p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
|
||
(run-with-store %store
|
||
(export-graph (list p3) 'port
|
||
#:node-type %package-node-type
|
||
#:backend backend))
|
||
;; We should see nothing more than these 3 packages.
|
||
(let-values (((nodes edges) (nodes+edges)))
|
||
(and (equal? nodes (map package->tuple (list p3 p2 p1)))
|
||
(equal? edges
|
||
(map edge->tuple
|
||
(list p3 p3 p2)
|
||
(list p2 p1 p1))))))))
|
||
|
||
(test-assert "bag-emerged DAG"
|
||
(let-values (((backend nodes+edges) (make-recording-backend)))
|
||
(let ((p (dummy-package "p"))
|
||
(implicit (map (match-lambda
|
||
((label package) package))
|
||
(standard-packages))))
|
||
(run-with-store %store
|
||
(export-graph (list p) 'port
|
||
#:node-type %bag-emerged-node-type
|
||
#:backend backend))
|
||
;; We should see exactly P and IMPLICIT, with one edge from P to each
|
||
;; element of IMPLICIT.
|
||
(let-values (((nodes edges) (nodes+edges)))
|
||
(and (equal? (match nodes
|
||
(((labels names) ...)
|
||
names))
|
||
(map package-full-name (cons p implicit)))
|
||
(equal? (match edges
|
||
(((sources destinations) ...)
|
||
(zip (map store-path-package-name sources)
|
||
(map store-path-package-name destinations))))
|
||
(map (lambda (destination)
|
||
(list "p-0.drv"
|
||
(string-append
|
||
(package-full-name destination)
|
||
".drv")))
|
||
implicit)))))))
|
||
|
||
(test-assert "bag DAG"
|
||
(let-values (((backend nodes+edges) (make-recording-backend)))
|
||
(let ((p (dummy-package "p")))
|
||
(run-with-store %store
|
||
(export-graph (list p) 'port
|
||
#:node-type %bag-node-type
|
||
#:backend backend))
|
||
;; We should see P, its implicit inputs as well as the whole DAG, which
|
||
;; should include bootstrap binaries.
|
||
(let-values (((nodes edges) (nodes+edges)))
|
||
(every (lambda (name)
|
||
(find (cut string=? name <>)
|
||
(match nodes
|
||
(((labels names) ...)
|
||
names))))
|
||
(match %bootstrap-inputs
|
||
(((labels packages) ...)
|
||
(map package-full-name packages))))))))
|
||
|
||
(test-assert "derivation DAG"
|
||
(let-values (((backend nodes+edges) (make-recording-backend)))
|
||
(run-with-store %store
|
||
(mlet* %store-monad ((txt (text-file "text-file" "Hello!"))
|
||
(guile (package->derivation %bootstrap-guile))
|
||
(drv (gexp->derivation "output"
|
||
#~(symlink #$txt #$output)
|
||
#:guile-for-build
|
||
guile)))
|
||
;; We should get at least these 3 nodes and corresponding edges.
|
||
(mbegin %store-monad
|
||
(export-graph (list drv) 'port
|
||
#:node-type %derivation-node-type
|
||
#:backend backend)
|
||
(let-values (((nodes edges) (nodes+edges)))
|
||
;; XXX: For some reason we need to throw in some 'basename'.
|
||
(return (and (match nodes
|
||
(((ids labels) ...)
|
||
(let ((ids (map basename ids)))
|
||
(every (lambda (item)
|
||
(member (basename item) ids))
|
||
(list txt
|
||
(derivation-file-name drv)
|
||
(derivation-file-name guile))))))
|
||
(every (cut member <>
|
||
(map (lambda (edge)
|
||
(map basename edge))
|
||
edges))
|
||
(list (map (compose basename derivation-file-name)
|
||
(list drv guile))
|
||
(list (basename (derivation-file-name drv))
|
||
(basename txt))))))))))))
|
||
|
||
(test-assert "reference DAG"
|
||
(let-values (((backend nodes+edges) (make-recording-backend)))
|
||
(run-with-store %store
|
||
(mlet* %store-monad ((txt (text-file "text-file" "Hello!"))
|
||
(guile (package->derivation %bootstrap-guile))
|
||
(drv (gexp->derivation "output"
|
||
#~(symlink #$txt #$output)
|
||
#:guile-for-build
|
||
guile))
|
||
(out -> (derivation->output-path drv)))
|
||
;; We should see only OUT and TXT, with an edge from the former to the
|
||
;; latter.
|
||
(mbegin %store-monad
|
||
(built-derivations (list drv))
|
||
(export-graph (list (derivation->output-path drv)) 'port
|
||
#:node-type %reference-node-type
|
||
#:backend backend)
|
||
(let-values (((nodes edges) (nodes+edges)))
|
||
(return
|
||
(and (equal? (match nodes
|
||
(((ids labels) ...)
|
||
ids))
|
||
(list out txt))
|
||
(equal? edges `((,out ,txt)))))))))))
|
||
|
||
(test-end "graph")
|
||
|
||
|
||
(exit (= (test-runner-fail-count (test-runner-current)) 0))
|