1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;; This file is part of GNU Guix.
7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
8 ;;; under the terms of the GNU General Public License as published by
9 ;;; the Free Software Foundation; either version 3 of the License, or (at
10 ;;; your option) any later version.
12 ;;; GNU Guix is distributed in the hope that it will be useful, but
13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details.
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20 (define-module (test-union)
21 #:use-module (guix tests)
22 #:use-module (guix store)
23 #:use-module (guix utils)
24 #:use-module (guix derivations)
25 #:use-module (guix packages)
26 #:use-module (guix build union)
27 #:use-module ((guix build utils)
28 #:select (with-directory-excursion directory-exists?))
29 #:use-module (gnu packages bootstrap)
30 #:use-module (srfi srfi-1)
31 #:use-module (srfi srfi-64)
32 #:use-module (rnrs io ports)
33 #:use-module (ice-9 match))
35 ;; Exercise the (guix build union) module.
38 (open-connection-for-tests))
43 (test-assert "union-build with symlink to directory"
44 ;; http://bugs.gnu.org/17083
45 ;; Here both ONE and TWO provide an element called 'foo', but in ONE it's a
46 ;; directory whereas in TWO it's a symlink to a directory.
47 (let* ((one (build-expression->derivation
50 (use-modules (guix build utils) (srfi srfi-26))
51 (let ((foo (string-append %output "/foo")))
53 (call-with-output-file (string-append foo "/one")
54 (cut display "one" <>))))
55 #:modules '((guix build utils))))
56 (two (build-expression->derivation
59 (use-modules (guix build utils) (srfi srfi-26))
60 (let ((foo (string-append %output "/foo"))
61 (bar (string-append %output "/bar")))
63 (call-with-output-file (string-append bar "/two")
64 (cut display "two" <>))
66 #:modules '((guix build utils))))
68 (use-modules (guix build union))
70 (union-build (assoc-ref %outputs "out")
71 (list (assoc-ref %build-inputs "one")
72 (assoc-ref %build-inputs "two")))))
74 (build-expression->derivation %store "union-collision-symlink"
76 #:inputs `(("one" ,one) ("two" ,two))
77 #:modules '((guix build union)))))
78 (and (build-derivations %store (list drv))
79 (with-directory-excursion (pk (derivation->output-path drv))
81 (call-with-input-file "foo/one" get-string-all))
83 (call-with-input-file "foo/two" get-string-all))
85 (call-with-input-file "bar/two" get-string-all))
86 (not (file-exists? "bar/one")))))))
88 (test-skip (if (and %store (network-reachable?))
92 (test-assert "union-build"
93 (let* ((inputs (map (match-lambda
95 `(,name ,(package-derivation %store package))))
97 ;; Purposefully leave duplicate entries.
98 (filter (compose package? cadr)
99 (append %bootstrap-inputs-for-tests
100 (take %bootstrap-inputs-for-tests 3)))))
102 (use-modules (guix build union))
103 (union-build (assoc-ref %outputs "out")
104 (map cdr %build-inputs))))
106 (build-expression->derivation %store "union-test"
109 #:modules '((guix build union)))))
110 (and (build-derivations %store (list (pk 'drv drv)))
111 (with-directory-excursion (derivation->output-path drv)
112 (and (file-exists? "bin/touch")
113 (file-exists? "bin/gcc")
114 (file-exists? "bin/ld")
115 (file-exists? "lib/libc.so")
116 (directory-exists? "lib/gcc")
117 (file-exists? "include/unistd.h")
119 ;; The 'include/c++' sub-directory is only found in
120 ;; gcc-bootstrap, so it should be unified in a
121 ;; straightforward way, without traversing it.
122 (eq? 'symlink (stat:type (lstat "include/c++")))
124 ;; Conversely, several inputs have a 'bin' sub-directory, so
125 ;; unifying it requires traversing them all, and creating a
126 ;; new 'bin' sub-directory in the profile.
127 (eq? 'directory (stat:type (lstat "bin"))))))))
129 (test-assert "union-build collision first & last"
130 (let* ((guile (package-derivation %store %bootstrap-guile))
131 (fake (build-expression->derivation
134 (use-modules (guix build utils))
135 (let ((out (assoc-ref %outputs "out")))
136 (mkdir-p (string-append out "/bin"))
137 (call-with-output-file (string-append out "/bin/guile")
139 #:modules '((guix build utils))))
140 (builder (lambda (policy)
142 (use-modules (guix build union)
144 (union-build (assoc-ref %outputs "out")
145 (map cdr %build-inputs)
146 #:resolve-collision ,policy))))
148 (build-expression->derivation %store "union-first"
150 #:inputs `(("guile" ,guile)
152 #:modules '((guix build union))))
154 (build-expression->derivation %store "union-last"
156 #:inputs `(("guile" ,guile)
158 #:modules '((guix build union)))))
159 (and (build-derivations %store (list drv1 drv2))
160 (with-directory-excursion (derivation->output-path drv1)
161 (string=? (readlink "bin/guile")
162 (string-append (derivation->output-path guile)
164 (with-directory-excursion (derivation->output-path drv2)
165 (string=? (readlink "bin/guile")
166 (string-append (derivation->output-path fake)
169 (test-assert "union-build #:create-all-directories? #t"
170 (let* ((build `(begin
171 (use-modules (guix build union))
172 (union-build (assoc-ref %outputs "out")
173 (map cdr %build-inputs)
174 #:create-all-directories? #t)))
175 (input (package-derivation %store %bootstrap-guile))
176 (drv (build-expression->derivation %store "union-test-all-dirs"
178 #:modules '((guix build union))
179 #:inputs `(("g" ,input)))))
180 (and (build-derivations %store (list drv))
181 (with-directory-excursion (derivation->output-path drv)
182 ;; Even though there's only one input to the union,
183 ;; #:create-all-directories? #t must have created bin/ rather than
184 ;; making it a symlink to Guile's bin/.
185 (and (file-exists? "bin/guile")
186 (file-is-directory? "bin")
187 (eq? 'symlink (stat:type (lstat "bin/guile"))))))))
189 (letrec-syntax ((test-relative-file-name
191 ((_ (reference file => expected) rest ...)
193 (test-equal (string-append "relative-file-name "
196 (relative-file-name reference file))
197 (test-relative-file-name rest ...)))
200 (test-relative-file-name
201 ("/a/b" "/a/c/d" => "../c/d")
202 ("/a/b" "/a/b" => "")
203 ("/a/b" "/a" => "..")
204 ("/a/b" "/a/b/c/d" => "c/d")
205 ("/a/b/c" "/a/d/e/f" => "../../d/e/f")))