Commit | Line | Data |
---|---|---|
7adf9b84 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2014, 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-grafts) | |
20 | #:use-module (guix derivations) | |
21 | #:use-module (guix store) | |
22 | #:use-module (guix utils) | |
23 | #:use-module (guix grafts) | |
24 | #:use-module (guix tests) | |
25 | #:use-module ((gnu packages) #:select (search-bootstrap-binary)) | |
26 | #:use-module (srfi srfi-64) | |
27 | #:use-module (rnrs io ports)) | |
28 | ||
29 | (define %store | |
30 | (open-connection-for-tests)) | |
31 | ||
32 | (define (bootstrap-binary name) | |
33 | (let ((bin (search-bootstrap-binary name (%current-system)))) | |
34 | (and %store | |
35 | (add-to-store %store name #t "sha256" bin)))) | |
36 | ||
37 | (define %bash | |
38 | (bootstrap-binary "bash")) | |
39 | (define %mkdir | |
40 | (bootstrap-binary "mkdir")) | |
41 | ||
42 | \f | |
43 | (test-begin "grafts") | |
44 | ||
45 | (test-assert "graft-derivation" | |
46 | (let* ((build `(begin | |
47 | (mkdir %output) | |
48 | (chdir %output) | |
49 | (symlink %output "self") | |
50 | (call-with-output-file "text" | |
51 | (lambda (output) | |
52 | (format output "foo/~a/bar" ,%mkdir))) | |
53 | (symlink ,%bash "sh"))) | |
54 | (orig (build-expression->derivation %store "graft" build | |
55 | #:inputs `(("a" ,%bash) | |
56 | ("b" ,%mkdir)))) | |
57 | (one (add-text-to-store %store "bash" "fake bash")) | |
58 | (two (build-expression->derivation %store "mkdir" | |
59 | '(call-with-output-file %output | |
60 | (lambda (port) | |
61 | (display "fake mkdir" port))))) | |
b0fef4d6 | 62 | (graft (graft-derivation %store orig |
7adf9b84 LC |
63 | (list (graft |
64 | (origin %bash) | |
65 | (replacement one)) | |
66 | (graft | |
67 | (origin %mkdir) | |
68 | (replacement two)))))) | |
69 | (and (build-derivations %store (list graft)) | |
70 | (let ((two (derivation->output-path two)) | |
71 | (graft (derivation->output-path graft))) | |
72 | (and (string=? (format #f "foo/~a/bar" two) | |
73 | (call-with-input-file (string-append graft "/text") | |
74 | get-string-all)) | |
75 | (string=? (readlink (string-append graft "/sh")) one) | |
76 | (string=? (readlink (string-append graft "/self")) graft)))))) | |
77 | ||
78 | (test-end) | |
79 | ||
80 | \f | |
81 | (exit (= (test-runner-fail-count (test-runner-current)) 0)) |