Commit | Line | Data |
---|---|---|
7adf9b84 | 1 | ;;; GNU Guix --- Functional package management for GNU |
1ba0b1e6 | 2 | ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
7adf9b84 LC |
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) | |
c22a1324 LC |
20 | #:use-module (guix gexp) |
21 | #:use-module (guix monads) | |
7adf9b84 LC |
22 | #:use-module (guix derivations) |
23 | #:use-module (guix store) | |
24 | #:use-module (guix utils) | |
25 | #:use-module (guix grafts) | |
26 | #:use-module (guix tests) | |
c22a1324 LC |
27 | #:use-module (gnu packages bootstrap) |
28 | #:use-module (srfi srfi-1) | |
7adf9b84 | 29 | #:use-module (srfi srfi-64) |
94e86a6b LC |
30 | #:use-module (rnrs bytevectors) |
31 | #:use-module (rnrs io ports) | |
32 | #:use-module (ice-9 vlist)) | |
7adf9b84 LC |
33 | |
34 | (define %store | |
35 | (open-connection-for-tests)) | |
36 | ||
37 | (define (bootstrap-binary name) | |
38 | (let ((bin (search-bootstrap-binary name (%current-system)))) | |
39 | (and %store | |
40 | (add-to-store %store name #t "sha256" bin)))) | |
41 | ||
42 | (define %bash | |
43 | (bootstrap-binary "bash")) | |
44 | (define %mkdir | |
45 | (bootstrap-binary "mkdir")) | |
46 | ||
47 | \f | |
48 | (test-begin "grafts") | |
49 | ||
64fd1c01 LC |
50 | (test-equal "graft-derivation, grafted item is a direct dependency" |
51 | '((type . graft) (graft (count . 2))) | |
7adf9b84 LC |
52 | (let* ((build `(begin |
53 | (mkdir %output) | |
54 | (chdir %output) | |
55 | (symlink %output "self") | |
56 | (call-with-output-file "text" | |
57 | (lambda (output) | |
58 | (format output "foo/~a/bar" ,%mkdir))) | |
59 | (symlink ,%bash "sh"))) | |
c22a1324 | 60 | (orig (build-expression->derivation %store "grafted" build |
7adf9b84 LC |
61 | #:inputs `(("a" ,%bash) |
62 | ("b" ,%mkdir)))) | |
63 | (one (add-text-to-store %store "bash" "fake bash")) | |
64 | (two (build-expression->derivation %store "mkdir" | |
65 | '(call-with-output-file %output | |
66 | (lambda (port) | |
67 | (display "fake mkdir" port))))) | |
c22a1324 LC |
68 | (grafted (graft-derivation %store orig |
69 | (list (graft | |
70 | (origin %bash) | |
71 | (replacement one)) | |
72 | (graft | |
73 | (origin %mkdir) | |
74 | (replacement two)))))) | |
75 | (and (build-derivations %store (list grafted)) | |
64fd1c01 LC |
76 | (let ((properties (derivation-properties grafted)) |
77 | (two (derivation->output-path two)) | |
78 | (grafted (derivation->output-path grafted))) | |
7adf9b84 | 79 | (and (string=? (format #f "foo/~a/bar" two) |
c22a1324 | 80 | (call-with-input-file (string-append grafted "/text") |
7adf9b84 | 81 | get-string-all)) |
c22a1324 LC |
82 | (string=? (readlink (string-append grafted "/sh")) one) |
83 | (string=? (readlink (string-append grafted "/self")) | |
64fd1c01 LC |
84 | grafted) |
85 | properties))))) | |
c22a1324 | 86 | |
57bdd79e LC |
87 | (test-assert "graft-derivation, grafted item uses a different name" |
88 | (let* ((build `(begin | |
89 | (mkdir %output) | |
90 | (chdir %output) | |
91 | (symlink %output "self") | |
92 | (symlink ,%bash "sh"))) | |
93 | (orig (build-expression->derivation %store "grafted" build | |
94 | #:inputs `(("a" ,%bash)))) | |
95 | (repl (add-text-to-store %store "BaSH" "fake bash")) | |
96 | (grafted (graft-derivation %store orig | |
97 | (list (graft | |
98 | (origin %bash) | |
99 | (replacement repl)))))) | |
100 | (and (build-derivations %store (list grafted)) | |
101 | (let ((grafted (derivation->output-path grafted))) | |
102 | (and (string=? (readlink (string-append grafted "/sh")) repl) | |
103 | (string=? (readlink (string-append grafted "/self")) | |
104 | grafted)))))) | |
105 | ||
c22a1324 LC |
106 | ;; Make sure 'derivation-file-name' always gets to see an absolute file name. |
107 | (fluid-set! %file-port-name-canonicalization 'absolute) | |
108 | ||
109 | (test-assert "graft-derivation, grafted item is an indirect dependency" | |
110 | (let* ((build `(begin | |
111 | (mkdir %output) | |
112 | (chdir %output) | |
113 | (symlink %output "self") | |
114 | (call-with-output-file "text" | |
115 | (lambda (output) | |
116 | (format output "foo/~a/bar" ,%mkdir))) | |
117 | (symlink ,%bash "sh"))) | |
118 | (dep (build-expression->derivation %store "dep" build | |
119 | #:inputs `(("a" ,%bash) | |
120 | ("b" ,%mkdir)))) | |
121 | (orig (build-expression->derivation %store "thing" | |
122 | '(symlink | |
123 | (assoc-ref %build-inputs | |
124 | "dep") | |
125 | %output) | |
126 | #:inputs `(("dep" ,dep)))) | |
127 | (one (add-text-to-store %store "bash" "fake bash")) | |
128 | (two (build-expression->derivation %store "mkdir" | |
129 | '(call-with-output-file %output | |
130 | (lambda (port) | |
131 | (display "fake mkdir" port))))) | |
132 | (grafted (graft-derivation %store orig | |
133 | (list (graft | |
134 | (origin %bash) | |
135 | (replacement one)) | |
136 | (graft | |
137 | (origin %mkdir) | |
138 | (replacement two)))))) | |
139 | (and (build-derivations %store (list grafted)) | |
140 | (let* ((two (derivation->output-path two)) | |
141 | (grafted (derivation->output-path grafted)) | |
142 | (dep (readlink grafted))) | |
143 | (and (string=? (format #f "foo/~a/bar" two) | |
144 | (call-with-input-file (string-append dep "/text") | |
145 | get-string-all)) | |
146 | (string=? (readlink (string-append dep "/sh")) one) | |
147 | (string=? (readlink (string-append dep "/self")) dep) | |
148 | (equal? (references %store grafted) (list dep)) | |
149 | (lset= string=? | |
150 | (list one two dep) | |
151 | (references %store dep))))))) | |
152 | ||
cf8b312d LC |
153 | (test-assert "graft-derivation, preserve empty directories" |
154 | (run-with-store %store | |
155 | (mlet* %store-monad ((fake (text-file "bash" "Fake bash.")) | |
156 | (graft -> (graft | |
157 | (origin %bash) | |
158 | (replacement fake))) | |
159 | (drv (gexp->derivation | |
160 | "to-graft" | |
66a35ceb LC |
161 | (with-imported-modules '((guix build utils)) |
162 | #~(begin | |
163 | (use-modules (guix build utils)) | |
164 | (mkdir-p (string-append #$output | |
165 | "/a/b/c/d")) | |
166 | (symlink #$%bash | |
167 | (string-append #$output | |
168 | "/bash")))))) | |
cf8b312d LC |
169 | (grafted ((store-lift graft-derivation) drv |
170 | (list graft))) | |
171 | (_ (built-derivations (list grafted))) | |
172 | (out -> (derivation->output-path grafted))) | |
173 | (return (and (string=? (readlink (string-append out "/bash")) | |
174 | fake) | |
175 | (file-is-directory? (string-append out "/a/b/c/d"))))))) | |
176 | ||
c22a1324 LC |
177 | (test-assert "graft-derivation, no dependencies on grafted output" |
178 | (run-with-store %store | |
179 | (mlet* %store-monad ((fake (text-file "bash" "Fake bash.")) | |
180 | (graft -> (graft | |
181 | (origin %bash) | |
182 | (replacement fake))) | |
183 | (drv (gexp->derivation "foo" #~(mkdir #$output))) | |
184 | (grafted ((store-lift graft-derivation) drv | |
185 | (list graft)))) | |
186 | (return (eq? grafted drv))))) | |
7adf9b84 | 187 | |
f376dc3a LC |
188 | (test-assert "graft-derivation, multiple outputs" |
189 | (let* ((build `(begin | |
190 | (symlink (assoc-ref %build-inputs "a") | |
191 | (assoc-ref %outputs "one")) | |
192 | (symlink (assoc-ref %outputs "one") | |
193 | (assoc-ref %outputs "two")))) | |
194 | (orig (build-expression->derivation %store "grafted" build | |
195 | #:inputs `(("a" ,%bash)) | |
196 | #:outputs '("one" "two"))) | |
197 | (repl (add-text-to-store %store "bash" "fake bash")) | |
198 | (grafted (graft-derivation %store orig | |
199 | (list (graft | |
200 | (origin %bash) | |
201 | (replacement repl)))))) | |
202 | (and (build-derivations %store (list grafted)) | |
203 | (let ((one (derivation->output-path grafted "one")) | |
204 | (two (derivation->output-path grafted "two"))) | |
205 | (and (string=? (readlink one) repl) | |
206 | (string=? (readlink two) one)))))) | |
207 | ||
3d47aa81 LC |
208 | (test-assert "graft-derivation, replaced derivation has multiple outputs" |
209 | ;; Here we have a replacement just for output "one" of P1 and not for the | |
210 | ;; other output. Make sure the graft for P1:one correctly applies to the | |
211 | ;; dependents of P1. See <http://bugs.gnu.org/24712>. | |
212 | (let* ((p1 (build-expression->derivation | |
213 | %store "p1" | |
214 | `(let ((one (assoc-ref %outputs "one")) | |
215 | (two (assoc-ref %outputs "two"))) | |
216 | (mkdir one) | |
217 | (mkdir two)) | |
218 | #:outputs '("one" "two"))) | |
219 | (p1r (build-expression->derivation | |
220 | %store "P1" | |
221 | `(let ((other (assoc-ref %outputs "ONE"))) | |
222 | (mkdir other) | |
223 | (call-with-output-file (string-append other "/replacement") | |
224 | (const #t))) | |
225 | #:outputs '("ONE"))) | |
226 | (p2 (build-expression->derivation | |
227 | %store "p2" | |
228 | `(let ((out (assoc-ref %outputs "aaa"))) | |
229 | (mkdir (assoc-ref %outputs "zzz")) | |
230 | (mkdir out) (chdir out) | |
231 | (symlink (assoc-ref %build-inputs "p1:one") "one") | |
232 | (symlink (assoc-ref %build-inputs "p1:two") "two")) | |
233 | #:outputs '("aaa" "zzz") | |
234 | #:inputs `(("p1:one" ,p1 "one") | |
235 | ("p1:two" ,p1 "two")))) | |
236 | (p3 (build-expression->derivation | |
237 | %store "p3" | |
238 | `(symlink (assoc-ref %build-inputs "p2:aaa") | |
239 | (assoc-ref %outputs "out")) | |
240 | #:inputs `(("p2:aaa" ,p2 "aaa") | |
241 | ("p2:zzz" ,p2 "zzz")))) | |
242 | (p1g (graft | |
243 | (origin p1) | |
244 | (origin-output "one") | |
245 | (replacement p1r) | |
246 | (replacement-output "ONE"))) | |
247 | (p3d (graft-derivation %store p3 (list p1g)))) | |
482fda27 LC |
248 | |
249 | (and (not (find (lambda (input) | |
250 | ;; INPUT should not be P2:zzz since the result of P3 | |
251 | ;; does not depend on it. See | |
252 | ;; <http://bugs.gnu.org/24886>. | |
253 | (and (string=? (derivation-input-path input) | |
254 | (derivation-file-name p2)) | |
255 | (member "zzz" | |
256 | (derivation-input-sub-derivations input)))) | |
257 | (derivation-inputs p3d))) | |
258 | ||
259 | (build-derivations %store (list p3d)) | |
3d47aa81 LC |
260 | (let ((out (derivation->output-path (pk 'p2d p3d)))) |
261 | (and (not (string=? (readlink out) | |
262 | (derivation->output-path p2 "aaa"))) | |
263 | (string=? (derivation->output-path p1 "two") | |
264 | (readlink (string-append out "/two"))) | |
265 | (file-exists? (string-append out "/one/replacement"))))))) | |
266 | ||
482fda27 LC |
267 | (test-assert "graft-derivation with #:outputs" |
268 | ;; Call 'graft-derivation' with a narrowed set of outputs passed as | |
269 | ;; #:outputs. | |
270 | (let* ((p1 (build-expression->derivation | |
271 | %store "p1" | |
272 | `(let ((one (assoc-ref %outputs "one")) | |
273 | (two (assoc-ref %outputs "two"))) | |
274 | (mkdir one) | |
275 | (mkdir two)) | |
276 | #:outputs '("one" "two"))) | |
277 | (p1r (build-expression->derivation | |
278 | %store "P1" | |
279 | `(let ((other (assoc-ref %outputs "ONE"))) | |
280 | (mkdir other) | |
281 | (call-with-output-file (string-append other "/replacement") | |
282 | (const #t))) | |
283 | #:outputs '("ONE"))) | |
284 | (p2 (build-expression->derivation | |
285 | %store "p2" | |
286 | `(let ((aaa (assoc-ref %outputs "aaa")) | |
287 | (zzz (assoc-ref %outputs "zzz"))) | |
288 | (mkdir zzz) (chdir zzz) | |
289 | (mkdir aaa) (chdir aaa) | |
290 | (symlink (assoc-ref %build-inputs "p1:two") "two")) | |
291 | #:outputs '("aaa" "zzz") | |
292 | #:inputs `(("p1:one" ,p1 "one") | |
293 | ("p1:two" ,p1 "two")))) | |
294 | (p1g (graft | |
295 | (origin p1) | |
296 | (origin-output "one") | |
297 | (replacement p1r) | |
298 | (replacement-output "ONE"))) | |
299 | (p2g (graft-derivation %store p2 (list p1g) | |
300 | #:outputs '("aaa")))) | |
301 | ;; P2:aaa depends on P1:two, but not on P1:one, so nothing to graft. | |
302 | (eq? p2g p2))) | |
303 | ||
304 | (test-equal "graft-derivation, unused outputs not depended on" | |
305 | '("aaa") | |
306 | ||
307 | ;; Make sure that the result of 'graft-derivation' does not pull outputs | |
308 | ;; that are irrelevant to the grafting process. See | |
309 | ;; <http://bugs.gnu.org/24886>. | |
310 | (let* ((p1 (build-expression->derivation | |
311 | %store "p1" | |
312 | `(let ((one (assoc-ref %outputs "one")) | |
313 | (two (assoc-ref %outputs "two"))) | |
314 | (mkdir one) | |
315 | (mkdir two)) | |
316 | #:outputs '("one" "two"))) | |
317 | (p1r (build-expression->derivation | |
318 | %store "P1" | |
319 | `(let ((other (assoc-ref %outputs "ONE"))) | |
320 | (mkdir other) | |
321 | (call-with-output-file (string-append other "/replacement") | |
322 | (const #t))) | |
323 | #:outputs '("ONE"))) | |
324 | (p2 (build-expression->derivation | |
325 | %store "p2" | |
326 | `(let ((aaa (assoc-ref %outputs "aaa")) | |
327 | (zzz (assoc-ref %outputs "zzz"))) | |
328 | (mkdir zzz) (chdir zzz) | |
329 | (symlink (assoc-ref %build-inputs "p1:two") "two") | |
330 | (mkdir aaa) (chdir aaa) | |
331 | (symlink (assoc-ref %build-inputs "p1:one") "one")) | |
332 | #:outputs '("aaa" "zzz") | |
333 | #:inputs `(("p1:one" ,p1 "one") | |
334 | ("p1:two" ,p1 "two")))) | |
335 | (p1g (graft | |
336 | (origin p1) | |
337 | (origin-output "one") | |
338 | (replacement p1r) | |
339 | (replacement-output "ONE"))) | |
340 | (p2g (graft-derivation %store p2 (list p1g) | |
341 | #:outputs '("aaa")))) | |
342 | ||
343 | ;; Here P2G should only depend on P1:one and P1R:one; it must not depend | |
344 | ;; on P1:two or P1R:two since these are unused in the grafting process. | |
345 | (and (not (eq? p2g p2)) | |
346 | (let* ((inputs (derivation-inputs p2g)) | |
347 | (match-input (lambda (drv) | |
348 | (lambda (input) | |
349 | (string=? (derivation-input-path input) | |
350 | (derivation-file-name drv))))) | |
351 | (p1-inputs (filter (match-input p1) inputs)) | |
352 | (p1r-inputs (filter (match-input p1r) inputs)) | |
353 | (p2-inputs (filter (match-input p2) inputs))) | |
354 | (and (equal? p1-inputs | |
c89985d9 | 355 | (list (derivation-input p1 '("one")))) |
482fda27 | 356 | (equal? p1r-inputs |
c89985d9 | 357 | (list (derivation-input p1r '("ONE")))) |
482fda27 | 358 | (equal? p2-inputs |
c89985d9 | 359 | (list (derivation-input p2 '("aaa")))) |
482fda27 LC |
360 | (derivation-output-names p2g)))))) |
361 | ||
ece6864b LC |
362 | (test-assert "graft-derivation, renaming" ;<http://bugs.gnu.org/23132> |
363 | (let* ((build `(begin | |
364 | (use-modules (guix build utils)) | |
365 | (mkdir-p (string-append (assoc-ref %outputs "out") "/" | |
366 | (assoc-ref %build-inputs "in"))))) | |
367 | (orig (build-expression->derivation %store "thing-to-graft" build | |
368 | #:modules '((guix build utils)) | |
369 | #:inputs `(("in" ,%bash)))) | |
370 | (repl (add-text-to-store %store "bash" "fake bash")) | |
371 | (grafted (graft-derivation %store orig | |
372 | (list (graft | |
373 | (origin %bash) | |
374 | (replacement repl)))))) | |
375 | (and (build-derivations %store (list grafted)) | |
376 | (let ((out (derivation->output-path grafted))) | |
377 | (file-is-directory? (string-append out "/" repl)))))) | |
378 | ||
b013c33f LC |
379 | (test-assert "graft-derivation, grafts are not shadowed" |
380 | ;; We build a DAG as below, where dotted arrows represent replacements and | |
381 | ;; solid arrows represent dependencies: | |
382 | ;; | |
383 | ;; P1 ·············> P1R | |
384 | ;; |\__________________. | |
385 | ;; v v | |
386 | ;; P2 ·············> P2R | |
387 | ;; | | |
388 | ;; v | |
389 | ;; P3 | |
390 | ;; | |
391 | ;; We want to make sure that the two grafts we want to apply to P3 are | |
392 | ;; honored and not shadowed by other computed grafts. | |
393 | (let* ((p1 (build-expression->derivation | |
394 | %store "p1" | |
395 | '(mkdir (assoc-ref %outputs "out")))) | |
396 | (p1r (build-expression->derivation | |
397 | %store "P1" | |
398 | '(let ((out (assoc-ref %outputs "out"))) | |
399 | (mkdir out) | |
400 | (call-with-output-file (string-append out "/replacement") | |
401 | (const #t))))) | |
402 | (p2 (build-expression->derivation | |
403 | %store "p2" | |
404 | `(let ((out (assoc-ref %outputs "out"))) | |
405 | (mkdir out) | |
406 | (chdir out) | |
407 | (symlink (assoc-ref %build-inputs "p1") "p1")) | |
408 | #:inputs `(("p1" ,p1)))) | |
409 | (p2r (build-expression->derivation | |
410 | %store "P2" | |
411 | `(let ((out (assoc-ref %outputs "out"))) | |
412 | (mkdir out) | |
413 | (chdir out) | |
414 | (symlink (assoc-ref %build-inputs "p1") "p1") | |
415 | (call-with-output-file (string-append out "/replacement") | |
416 | (const #t))) | |
417 | #:inputs `(("p1" ,p1)))) | |
418 | (p3 (build-expression->derivation | |
419 | %store "p3" | |
420 | `(let ((out (assoc-ref %outputs "out"))) | |
421 | (mkdir out) | |
422 | (chdir out) | |
423 | (symlink (assoc-ref %build-inputs "p2") "p2")) | |
424 | #:inputs `(("p2" ,p2)))) | |
425 | (p1g (graft | |
426 | (origin p1) | |
427 | (replacement p1r))) | |
428 | (p2g (graft | |
429 | (origin p2) | |
430 | (replacement (graft-derivation %store p2r (list p1g))))) | |
431 | (p3d (graft-derivation %store p3 (list p1g p2g)))) | |
432 | (and (build-derivations %store (list p3d)) | |
433 | (let ((out (derivation->output-path (pk p3d)))) | |
434 | ;; Make sure OUT refers to the replacement of P2, which in turn | |
435 | ;; refers to the replacement of P1, as specified by P1G and P2G. | |
436 | ;; It used to be the case that P2G would be shadowed by a simple | |
437 | ;; P2->P2R graft, which is not what we want. | |
438 | (and (file-exists? (string-append out "/p2/replacement")) | |
439 | (file-exists? (string-append out "/p2/p1/replacement"))))))) | |
440 | ||
94e86a6b LC |
441 | (define buffer-size |
442 | ;; Must be equal to REQUEST-SIZE in 'replace-store-references'. | |
443 | (expt 2 20)) | |
444 | ||
445 | (test-equal "replace-store-references, <http://bugs.gnu.org/28212>" | |
446 | (string-append (make-string (- buffer-size 47) #\a) | |
447 | "/gnu/store/" (make-string 32 #\8) | |
448 | "-SoMeTHiNG" | |
449 | (list->string (map integer->char (iota 77 33)))) | |
450 | ||
451 | ;; Create input data where the right-hand-size of the dash ("-something" | |
452 | ;; here) goes beyond the end of the internal buffer of | |
453 | ;; 'replace-store-references'. | |
454 | (let* ((content (string-append (make-string (- buffer-size 47) #\a) | |
455 | "/gnu/store/" (make-string 32 #\7) | |
456 | "-something" | |
457 | (list->string | |
458 | (map integer->char (iota 77 33))))) | |
459 | (replacement (alist->vhash | |
460 | `((,(make-string 32 #\7) | |
461 | . ,(string->utf8 (string-append | |
462 | (make-string 32 #\8) | |
463 | "-SoMeTHiNG"))))))) | |
464 | (call-with-output-string | |
465 | (lambda (output) | |
466 | ((@@ (guix build graft) replace-store-references) | |
467 | (open-input-string content) output | |
468 | replacement | |
469 | "/gnu/store"))))) | |
470 | ||
7adf9b84 | 471 | (test-end) |