projects/guix·blob sysadmin-team · refs

205 lines · 9.4 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <[email protected]>
3;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
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.
11;;;
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.
16;;;
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/>.
19
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))
34
35;; Exercise the (guix build union) module.
36
37(define %store
38 (open-connection-for-tests))
39
40
41(test-begin "union")
42
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
48 %store "one"
49 '(begin
50 (use-modules (guix build utils) (srfi srfi-26))
51 (let ((foo (string-append %output "/foo")))
52 (mkdir-p foo)
53 (call-with-output-file (string-append foo "/one")
54 (cut display "one" <>))))
55 #:modules '((guix build utils))))
56 (two (build-expression->derivation
57 %store "two"
58 '(begin
59 (use-modules (guix build utils) (srfi srfi-26))
60 (let ((foo (string-append %output "/foo"))
61 (bar (string-append %output "/bar")))
62 (mkdir-p bar)
63 (call-with-output-file (string-append bar "/two")
64 (cut display "two" <>))
65 (symlink "bar" foo)))
66 #:modules '((guix build utils))))
67 (builder '(begin
68 (use-modules (guix build union))
69
70 (union-build (assoc-ref %outputs "out")
71 (list (assoc-ref %build-inputs "one")
72 (assoc-ref %build-inputs "two")))))
73 (drv
74 (build-expression->derivation %store "union-collision-symlink"
75 builder
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))
80 (and (string=? "one"
81 (call-with-input-file "foo/one" get-string-all))
82 (string=? "two"
83 (call-with-input-file "foo/two" get-string-all))
84 (string=? "two"
85 (call-with-input-file "bar/two" get-string-all))
86 (not (file-exists? "bar/one")))))))
87
88(test-skip (if (and %store (network-reachable?))
89 0
90 1))
91
92(test-assert "union-build"
93 (let* ((inputs (map (lambda (package)
94 (list (package-name package)
95 (package-derivation %store package)))
96 ;; Purposefully leave duplicate entries.
97 (append %bootstrap-inputs-for-tests
98 (take %bootstrap-inputs-for-tests 3))))
99 (builder `(begin
100 (use-modules (guix build union))
101 (union-build (assoc-ref %outputs "out")
102 (map cdr %build-inputs))))
103 (drv
104 (build-expression->derivation %store "union-test"
105 builder
106 #:inputs inputs
107 #:modules '((guix build union)))))
108 (and (build-derivations %store (list (pk 'drv drv)))
109 (with-directory-excursion (derivation->output-path drv)
110 (and (file-exists? "bin/touch")
111 (file-exists? "bin/gcc")
112 (file-exists? "bin/ld")
113 (file-exists? "lib/libc.so")
114 (directory-exists? "lib/gcc")
115 (file-exists? "include/unistd.h")
116
117 ;; The 'include/c++' sub-directory is only found in
118 ;; gcc-bootstrap, so it should be unified in a
119 ;; straightforward way, without traversing it.
120 (eq? 'symlink (stat:type (lstat "include/c++")))
121
122 ;; Conversely, several inputs have a 'bin' sub-directory, so
123 ;; unifying it requires traversing them all, and creating a
124 ;; new 'bin' sub-directory in the profile.
125 (eq? 'directory (stat:type (lstat "bin"))))))))
126
127(test-assert "union-build collision first & last"
128 (let* ((guile (package-derivation %store %bootstrap-guile))
129 (fake (build-expression->derivation
130 %store "fake-guile"
131 '(begin
132 (use-modules (guix build utils))
133 (let ((out (assoc-ref %outputs "out")))
134 (mkdir-p (string-append out "/bin"))
135 (call-with-output-file (string-append out "/bin/guile")
136 (const #t))))
137 #:modules '((guix build utils))))
138 (builder (lambda (policy)
139 `(begin
140 (use-modules (guix build union)
141 (srfi srfi-1))
142 (union-build (assoc-ref %outputs "out")
143 (map cdr %build-inputs)
144 #:resolve-collision ,policy))))
145 (drv1
146 (build-expression->derivation %store "union-first"
147 (builder 'first)
148 #:inputs `(("guile" ,guile)
149 ("fake" ,fake))
150 #:modules '((guix build union))))
151 (drv2
152 (build-expression->derivation %store "union-last"
153 (builder 'last)
154 #:inputs `(("guile" ,guile)
155 ("fake" ,fake))
156 #:modules '((guix build union)))))
157 (and (build-derivations %store (list drv1 drv2))
158 (with-directory-excursion (derivation->output-path drv1)
159 (string=? (readlink "bin/guile")
160 (string-append (derivation->output-path guile)
161 "/bin/guile")))
162 (with-directory-excursion (derivation->output-path drv2)
163 (string=? (readlink "bin/guile")
164 (string-append (derivation->output-path fake)
165 "/bin/guile"))))))
166
167(test-assert "union-build #:create-all-directories? #t"
168 (let* ((build `(begin
169 (use-modules (guix build union))
170 (union-build (assoc-ref %outputs "out")
171 (map cdr %build-inputs)
172 #:create-all-directories? #t)))
173 (input (package-derivation %store %bootstrap-guile))
174 (drv (build-expression->derivation %store "union-test-all-dirs"
175 build
176 #:modules '((guix build union))
177 #:inputs `(("g" ,input)))))
178 (and (build-derivations %store (list drv))
179 (with-directory-excursion (derivation->output-path drv)
180 ;; Even though there's only one input to the union,
181 ;; #:create-all-directories? #t must have created bin/ rather than
182 ;; making it a symlink to Guile's bin/.
183 (and (file-exists? "bin/guile")
184 (file-is-directory? "bin")
185 (eq? 'symlink (stat:type (lstat "bin/guile"))))))))
186
187(letrec-syntax ((test-relative-file-name
188 (syntax-rules (=>)
189 ((_ (reference file => expected) rest ...)
190 (begin
191 (test-equal (string-append "relative-file-name "
192 reference " " file)
193 expected
194 (relative-file-name reference file))
195 (test-relative-file-name rest ...)))
196 ((_)
197 #t))))
198 (test-relative-file-name
199 ("/a/b" "/a/c/d" => "../c/d")
200 ("/a/b" "/a/b" => "")
201 ("/a/b" "/a" => "..")
202 ("/a/b" "/a/b/c/d" => "c/d")
203 ("/a/b/c" "/a/d/e/f" => "../../d/e/f")))
204
205(test-end)