1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
19 (define-module (test-grafts)
20 #:use-module (guix gexp)
21 #:use-module (guix monads)
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)
27 #:use-module ((gnu packages) #:select (search-bootstrap-binary))
28 #:use-module (gnu packages bootstrap)
29 #:use-module (srfi srfi-1)
30 #:use-module (srfi srfi-64)
31 #:use-module (rnrs bytevectors)
32 #:use-module (rnrs io ports)
33 #:use-module (ice-9 vlist))
36 (open-connection-for-tests))
38 (define (bootstrap-binary name)
39 (let ((bin (search-bootstrap-binary name (%current-system))))
41 (add-to-store %store name #t "sha256" bin))))
44 (bootstrap-binary "bash"))
46 (bootstrap-binary "mkdir"))
48 (define make-derivation-input
49 (@@ (guix derivations) make-derivation-input))
54 (test-equal "graft-derivation, grafted item is a direct dependency"
55 '((type . graft) (graft (count . 2)))
59 (symlink %output "self")
60 (call-with-output-file "text"
62 (format output "foo/~a/bar" ,%mkdir)))
63 (symlink ,%bash "sh")))
64 (orig (build-expression->derivation %store "grafted" build
65 #:inputs `(("a" ,%bash)
67 (one (add-text-to-store %store "bash" "fake bash"))
68 (two (build-expression->derivation %store "mkdir"
69 '(call-with-output-file %output
71 (display "fake mkdir" port)))))
72 (grafted (graft-derivation %store orig
78 (replacement two))))))
79 (and (build-derivations %store (list grafted))
80 (let ((properties (derivation-properties grafted))
81 (two (derivation->output-path two))
82 (grafted (derivation->output-path grafted)))
83 (and (string=? (format #f "foo/~a/bar" two)
84 (call-with-input-file (string-append grafted "/text")
86 (string=? (readlink (string-append grafted "/sh")) one)
87 (string=? (readlink (string-append grafted "/self"))
91 (test-assert "graft-derivation, grafted item uses a different name"
95 (symlink %output "self")
96 (symlink ,%bash "sh")))
97 (orig (build-expression->derivation %store "grafted" build
98 #:inputs `(("a" ,%bash))))
99 (repl (add-text-to-store %store "BaSH" "fake bash"))
100 (grafted (graft-derivation %store orig
103 (replacement repl))))))
104 (and (build-derivations %store (list grafted))
105 (let ((grafted (derivation->output-path grafted)))
106 (and (string=? (readlink (string-append grafted "/sh")) repl)
107 (string=? (readlink (string-append grafted "/self"))
110 ;; Make sure 'derivation-file-name' always gets to see an absolute file name.
111 (fluid-set! %file-port-name-canonicalization 'absolute)
113 (test-assert "graft-derivation, grafted item is an indirect dependency"
114 (let* ((build `(begin
117 (symlink %output "self")
118 (call-with-output-file "text"
120 (format output "foo/~a/bar" ,%mkdir)))
121 (symlink ,%bash "sh")))
122 (dep (build-expression->derivation %store "dep" build
123 #:inputs `(("a" ,%bash)
125 (orig (build-expression->derivation %store "thing"
127 (assoc-ref %build-inputs
130 #:inputs `(("dep" ,dep))))
131 (one (add-text-to-store %store "bash" "fake bash"))
132 (two (build-expression->derivation %store "mkdir"
133 '(call-with-output-file %output
135 (display "fake mkdir" port)))))
136 (grafted (graft-derivation %store orig
142 (replacement two))))))
143 (and (build-derivations %store (list grafted))
144 (let* ((two (derivation->output-path two))
145 (grafted (derivation->output-path grafted))
146 (dep (readlink grafted)))
147 (and (string=? (format #f "foo/~a/bar" two)
148 (call-with-input-file (string-append dep "/text")
150 (string=? (readlink (string-append dep "/sh")) one)
151 (string=? (readlink (string-append dep "/self")) dep)
152 (equal? (references %store grafted) (list dep))
155 (references %store dep)))))))
157 (test-assert "graft-derivation, preserve empty directories"
158 (run-with-store %store
159 (mlet* %store-monad ((fake (text-file "bash" "Fake bash."))
163 (drv (gexp->derivation
165 (with-imported-modules '((guix build utils))
167 (use-modules (guix build utils))
168 (mkdir-p (string-append #$output
171 (string-append #$output
173 (grafted ((store-lift graft-derivation) drv
175 (_ (built-derivations (list grafted)))
176 (out -> (derivation->output-path grafted)))
177 (return (and (string=? (readlink (string-append out "/bash"))
179 (file-is-directory? (string-append out "/a/b/c/d")))))))
181 (test-assert "graft-derivation, no dependencies on grafted output"
182 (run-with-store %store
183 (mlet* %store-monad ((fake (text-file "bash" "Fake bash."))
187 (drv (gexp->derivation "foo" #~(mkdir #$output)))
188 (grafted ((store-lift graft-derivation) drv
190 (return (eq? grafted drv)))))
192 (test-assert "graft-derivation, multiple outputs"
193 (let* ((build `(begin
194 (symlink (assoc-ref %build-inputs "a")
195 (assoc-ref %outputs "one"))
196 (symlink (assoc-ref %outputs "one")
197 (assoc-ref %outputs "two"))))
198 (orig (build-expression->derivation %store "grafted" build
199 #:inputs `(("a" ,%bash))
200 #:outputs '("one" "two")))
201 (repl (add-text-to-store %store "bash" "fake bash"))
202 (grafted (graft-derivation %store orig
205 (replacement repl))))))
206 (and (build-derivations %store (list grafted))
207 (let ((one (derivation->output-path grafted "one"))
208 (two (derivation->output-path grafted "two")))
209 (and (string=? (readlink one) repl)
210 (string=? (readlink two) one))))))
212 (test-assert "graft-derivation, replaced derivation has multiple outputs"
213 ;; Here we have a replacement just for output "one" of P1 and not for the
214 ;; other output. Make sure the graft for P1:one correctly applies to the
215 ;; dependents of P1. See <http://bugs.gnu.org/24712>.
216 (let* ((p1 (build-expression->derivation
218 `(let ((one (assoc-ref %outputs "one"))
219 (two (assoc-ref %outputs "two")))
222 #:outputs '("one" "two")))
223 (p1r (build-expression->derivation
225 `(let ((other (assoc-ref %outputs "ONE")))
227 (call-with-output-file (string-append other "/replacement")
230 (p2 (build-expression->derivation
232 `(let ((out (assoc-ref %outputs "aaa")))
233 (mkdir (assoc-ref %outputs "zzz"))
234 (mkdir out) (chdir out)
235 (symlink (assoc-ref %build-inputs "p1:one") "one")
236 (symlink (assoc-ref %build-inputs "p1:two") "two"))
237 #:outputs '("aaa" "zzz")
238 #:inputs `(("p1:one" ,p1 "one")
239 ("p1:two" ,p1 "two"))))
240 (p3 (build-expression->derivation
242 `(symlink (assoc-ref %build-inputs "p2:aaa")
243 (assoc-ref %outputs "out"))
244 #:inputs `(("p2:aaa" ,p2 "aaa")
245 ("p2:zzz" ,p2 "zzz"))))
248 (origin-output "one")
250 (replacement-output "ONE")))
251 (p3d (graft-derivation %store p3 (list p1g))))
253 (and (not (find (lambda (input)
254 ;; INPUT should not be P2:zzz since the result of P3
255 ;; does not depend on it. See
256 ;; <http://bugs.gnu.org/24886>.
257 (and (string=? (derivation-input-path input)
258 (derivation-file-name p2))
260 (derivation-input-sub-derivations input))))
261 (derivation-inputs p3d)))
263 (build-derivations %store (list p3d))
264 (let ((out (derivation->output-path (pk 'p2d p3d))))
265 (and (not (string=? (readlink out)
266 (derivation->output-path p2 "aaa")))
267 (string=? (derivation->output-path p1 "two")
268 (readlink (string-append out "/two")))
269 (file-exists? (string-append out "/one/replacement")))))))
271 (test-assert "graft-derivation with #:outputs"
272 ;; Call 'graft-derivation' with a narrowed set of outputs passed as
274 (let* ((p1 (build-expression->derivation
276 `(let ((one (assoc-ref %outputs "one"))
277 (two (assoc-ref %outputs "two")))
280 #:outputs '("one" "two")))
281 (p1r (build-expression->derivation
283 `(let ((other (assoc-ref %outputs "ONE")))
285 (call-with-output-file (string-append other "/replacement")
288 (p2 (build-expression->derivation
290 `(let ((aaa (assoc-ref %outputs "aaa"))
291 (zzz (assoc-ref %outputs "zzz")))
292 (mkdir zzz) (chdir zzz)
293 (mkdir aaa) (chdir aaa)
294 (symlink (assoc-ref %build-inputs "p1:two") "two"))
295 #:outputs '("aaa" "zzz")
296 #:inputs `(("p1:one" ,p1 "one")
297 ("p1:two" ,p1 "two"))))
300 (origin-output "one")
302 (replacement-output "ONE")))
303 (p2g (graft-derivation %store p2 (list p1g)
304 #:outputs '("aaa"))))
305 ;; P2:aaa depends on P1:two, but not on P1:one, so nothing to graft.
308 (test-equal "graft-derivation, unused outputs not depended on"
311 ;; Make sure that the result of 'graft-derivation' does not pull outputs
312 ;; that are irrelevant to the grafting process. See
313 ;; <http://bugs.gnu.org/24886>.
314 (let* ((p1 (build-expression->derivation
316 `(let ((one (assoc-ref %outputs "one"))
317 (two (assoc-ref %outputs "two")))
320 #:outputs '("one" "two")))
321 (p1r (build-expression->derivation
323 `(let ((other (assoc-ref %outputs "ONE")))
325 (call-with-output-file (string-append other "/replacement")
328 (p2 (build-expression->derivation
330 `(let ((aaa (assoc-ref %outputs "aaa"))
331 (zzz (assoc-ref %outputs "zzz")))
332 (mkdir zzz) (chdir zzz)
333 (symlink (assoc-ref %build-inputs "p1:two") "two")
334 (mkdir aaa) (chdir aaa)
335 (symlink (assoc-ref %build-inputs "p1:one") "one"))
336 #:outputs '("aaa" "zzz")
337 #:inputs `(("p1:one" ,p1 "one")
338 ("p1:two" ,p1 "two"))))
341 (origin-output "one")
343 (replacement-output "ONE")))
344 (p2g (graft-derivation %store p2 (list p1g)
345 #:outputs '("aaa"))))
347 ;; Here P2G should only depend on P1:one and P1R:one; it must not depend
348 ;; on P1:two or P1R:two since these are unused in the grafting process.
349 (and (not (eq? p2g p2))
350 (let* ((inputs (derivation-inputs p2g))
351 (match-input (lambda (drv)
353 (string=? (derivation-input-path input)
354 (derivation-file-name drv)))))
355 (p1-inputs (filter (match-input p1) inputs))
356 (p1r-inputs (filter (match-input p1r) inputs))
357 (p2-inputs (filter (match-input p2) inputs)))
358 (and (equal? p1-inputs
359 (list (make-derivation-input (derivation-file-name p1)
363 (make-derivation-input (derivation-file-name p1r)
367 (make-derivation-input (derivation-file-name p2)
369 (derivation-output-names p2g))))))
371 (test-assert "graft-derivation, renaming" ;<http://bugs.gnu.org/23132>
372 (let* ((build `(begin
373 (use-modules (guix build utils))
374 (mkdir-p (string-append (assoc-ref %outputs "out") "/"
375 (assoc-ref %build-inputs "in")))))
376 (orig (build-expression->derivation %store "thing-to-graft" build
377 #:modules '((guix build utils))
378 #:inputs `(("in" ,%bash))))
379 (repl (add-text-to-store %store "bash" "fake bash"))
380 (grafted (graft-derivation %store orig
383 (replacement repl))))))
384 (and (build-derivations %store (list grafted))
385 (let ((out (derivation->output-path grafted)))
386 (file-is-directory? (string-append out "/" repl))))))
388 (test-assert "graft-derivation, grafts are not shadowed"
389 ;; We build a DAG as below, where dotted arrows represent replacements and
390 ;; solid arrows represent dependencies:
392 ;; P1 ·············> P1R
393 ;; |\__________________.
395 ;; P2 ·············> P2R
400 ;; We want to make sure that the two grafts we want to apply to P3 are
401 ;; honored and not shadowed by other computed grafts.
402 (let* ((p1 (build-expression->derivation
404 '(mkdir (assoc-ref %outputs "out"))))
405 (p1r (build-expression->derivation
407 '(let ((out (assoc-ref %outputs "out")))
409 (call-with-output-file (string-append out "/replacement")
411 (p2 (build-expression->derivation
413 `(let ((out (assoc-ref %outputs "out")))
416 (symlink (assoc-ref %build-inputs "p1") "p1"))
417 #:inputs `(("p1" ,p1))))
418 (p2r (build-expression->derivation
420 `(let ((out (assoc-ref %outputs "out")))
423 (symlink (assoc-ref %build-inputs "p1") "p1")
424 (call-with-output-file (string-append out "/replacement")
426 #:inputs `(("p1" ,p1))))
427 (p3 (build-expression->derivation
429 `(let ((out (assoc-ref %outputs "out")))
432 (symlink (assoc-ref %build-inputs "p2") "p2"))
433 #:inputs `(("p2" ,p2))))
439 (replacement (graft-derivation %store p2r (list p1g)))))
440 (p3d (graft-derivation %store p3 (list p1g p2g))))
441 (and (build-derivations %store (list p3d))
442 (let ((out (derivation->output-path (pk p3d))))
443 ;; Make sure OUT refers to the replacement of P2, which in turn
444 ;; refers to the replacement of P1, as specified by P1G and P2G.
445 ;; It used to be the case that P2G would be shadowed by a simple
446 ;; P2->P2R graft, which is not what we want.
447 (and (file-exists? (string-append out "/p2/replacement"))
448 (file-exists? (string-append out "/p2/p1/replacement")))))))
451 ;; Must be equal to REQUEST-SIZE in 'replace-store-references'.
454 (test-equal "replace-store-references, <http://bugs.gnu.org/28212>"
455 (string-append (make-string (- buffer-size 47) #\a)
456 "/gnu/store/" (make-string 32 #\8)
458 (list->string (map integer->char (iota 77 33))))
460 ;; Create input data where the right-hand-size of the dash ("-something"
461 ;; here) goes beyond the end of the internal buffer of
462 ;; 'replace-store-references'.
463 (let* ((content (string-append (make-string (- buffer-size 47) #\a)
464 "/gnu/store/" (make-string 32 #\7)
467 (map integer->char (iota 77 33)))))
468 (replacement (alist->vhash
469 `((,(make-string 32 #\7)
470 . ,(string->utf8 (string-append
473 (call-with-output-string
475 ((@@ (guix build graft) replace-store-references)
476 (open-input-string content) output