projects/guix·blob a04b886f · refs

790 lines · 37.7 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2014-2019, 2022-2023 Ludovic Courtès <[email protected]>
3;;; Copyright © 2021 Mark H Weaver <[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-grafts)
21 #:use-module (guix gexp)
22 #:use-module (guix monads)
23 #:use-module (guix derivations)
24 #:use-module (guix store)
25 #:use-module (guix utils)
26 #:use-module (guix grafts)
27 #:use-module (guix tests)
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))
34
35(define %store
36 (open-connection-for-tests))
37
38;; When grafting, do not add dependency on 'glibc-utf8-locales'.
39(%graft-with-utf8-locale? #f)
40
41(define (bootstrap-binary name)
42 (let ((bin (search-bootstrap-binary name (%current-system))))
43 (and %store
44 (add-to-store %store name #t "sha256" bin))))
45
46(define %bash
47 (bootstrap-binary "bash"))
48(define %mkdir
49 (bootstrap-binary "mkdir"))
50
51
52(test-begin "grafts")
53
54(test-equal "graft-derivation, grafted item is a direct dependency"
55 '((type . graft) (graft (count . 2)))
56 (let* ((build `(begin
57 (mkdir %output)
58 (chdir %output)
59 (symlink %output "self")
60 (call-with-output-file "text"
61 (lambda (output)
62 (format output "foo/~a/bar" ,%mkdir)))
63 (symlink ,%bash "sh")))
64 (orig (build-expression->derivation %store "grafted" build
65 #:inputs `(("a" ,%bash)
66 ("b" ,%mkdir))))
67 (one (add-text-to-store %store "bash" "fake bash"))
68 (two (build-expression->derivation %store "mkdir"
69 '(call-with-output-file %output
70 (lambda (port)
71 (display "fake mkdir" port)))))
72 (grafted (graft-derivation %store orig
73 (list (graft
74 (origin %bash)
75 (replacement one))
76 (graft
77 (origin %mkdir)
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")
85 get-string-all))
86 (string=? (readlink (string-append grafted "/sh")) one)
87 (string=? (readlink (string-append grafted "/self"))
88 grafted)
89 properties)))))
90
91(test-assert "graft-derivation, grafted item uses a different name"
92 (let* ((build `(begin
93 (mkdir %output)
94 (chdir %output)
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
101 (list (graft
102 (origin %bash)
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"))
108 grafted))))))
109
110;; Make sure 'derivation-file-name' always gets to see an absolute file name.
111(fluid-set! %file-port-name-canonicalization 'absolute)
112
113(test-assert "graft-derivation, grafted item is an indirect dependency"
114 (let* ((build `(begin
115 (mkdir %output)
116 (chdir %output)
117 (symlink %output "self")
118 (call-with-output-file "text"
119 (lambda (output)
120 (format output "foo/~a/bar" ,%mkdir)))
121 (symlink ,%bash "sh")))
122 (dep (build-expression->derivation %store "dep" build
123 #:inputs `(("a" ,%bash)
124 ("b" ,%mkdir))))
125 (orig (build-expression->derivation %store "thing"
126 '(symlink
127 (assoc-ref %build-inputs
128 "dep")
129 %output)
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
134 (lambda (port)
135 (display "fake mkdir" port)))))
136 (grafted (graft-derivation %store orig
137 (list (graft
138 (origin %bash)
139 (replacement one))
140 (graft
141 (origin %mkdir)
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")
149 get-string-all))
150 (string=? (readlink (string-append dep "/sh")) one)
151 (string=? (readlink (string-append dep "/self")) dep)
152 (equal? (references %store grafted) (list dep))
153 (lset= string=?
154 (list one two dep)
155 (references %store dep)))))))
156
157(test-assert "graft-derivation, preserve empty directories"
158 (run-with-store %store
159 (mlet* %store-monad ((fake (text-file "bash" "Fake bash."))
160 (graft -> (graft
161 (origin %bash)
162 (replacement fake)))
163 (drv (gexp->derivation
164 "to-graft"
165 (with-imported-modules '((guix build utils))
166 #~(begin
167 (use-modules (guix build utils))
168 (mkdir-p (string-append #$output
169 "/a/b/c/d"))
170 (symlink #$%bash
171 (string-append #$output
172 "/bash"))))))
173 (grafted ((store-lift graft-derivation) drv
174 (list graft)))
175 (_ (built-derivations (list grafted)))
176 (out -> (derivation->output-path grafted)))
177 (return (and (string=? (readlink (string-append out "/bash"))
178 fake)
179 (file-is-directory? (string-append out "/a/b/c/d")))))))
180
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."))
184 (graft -> (graft
185 (origin %bash)
186 (replacement fake)))
187 (drv (gexp->derivation "foo" #~(mkdir #$output)))
188 (grafted ((store-lift graft-derivation) drv
189 (list graft))))
190 (return (eq? grafted drv)))))
191
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
203 (list (graft
204 (origin %bash)
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))))))
211
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
217 %store "p1"
218 `(let ((one (assoc-ref %outputs "one"))
219 (two (assoc-ref %outputs "two")))
220 (mkdir one)
221 (mkdir two))
222 #:outputs '("one" "two")))
223 (p1r (build-expression->derivation
224 %store "P1"
225 `(let ((other (assoc-ref %outputs "ONE")))
226 (mkdir other)
227 (call-with-output-file (string-append other "/replacement")
228 (const #t)))
229 #:outputs '("ONE")))
230 (p2 (build-expression->derivation
231 %store "p2"
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
241 %store "p3"
242 `(symlink (assoc-ref %build-inputs "p2:aaa")
243 (assoc-ref %outputs "out"))
244 #:inputs `(("p2:aaa" ,p2 "aaa")
245 ("p2:zzz" ,p2 "zzz"))))
246 (p1g (graft
247 (origin p1)
248 (origin-output "one")
249 (replacement p1r)
250 (replacement-output "ONE")))
251 (p3d (graft-derivation %store p3 (list p1g))))
252
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))
259 (member "zzz"
260 (derivation-input-sub-derivations input))))
261 (derivation-inputs p3d)))
262
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")))))))
270
271(test-assert "graft-derivation, multiple outputs need to be replaced"
272 ;; Build a reference graph like this:
273 ;;
274 ;; ,- p2:out --.
275 ;; v v
276 ;; p1:one <---- p1:two
277 ;; |
278 ;; `-> p0
279 ;;
280 ;; Graft p0r in lieu of p0, and make sure all the paths from the grafted p2
281 ;; lead to p0r. See <https://issues.guix.gnu.org/66662>.
282 (let* ((p0 (build-expression->derivation
283 %store "p0" '(mkdir (assoc-ref %outputs "out"))))
284 (p0r (build-expression->derivation
285 %store "P0"
286 '(let ((out (assoc-ref %outputs "out")))
287 (mkdir out)
288 (call-with-output-file (string-append out "/replacement")
289 (const #t)))))
290 (p1 (build-expression->derivation
291 %store "p1"
292 `(let ((one (assoc-ref %outputs "one"))
293 (two (assoc-ref %outputs "two"))
294 (p0 (assoc-ref %build-inputs "p0")))
295 (mkdir one)
296 (mkdir two)
297 (symlink p0 (string-append one "/p0"))
298 (symlink one (string-append two "/link")))
299 #:inputs `(("p0" ,p0))
300 #:outputs '("one" "two")))
301 (p2 (build-expression->derivation
302 %store "p2"
303 `(let ((out (assoc-ref %outputs "out")))
304 (mkdir out) (chdir out)
305 (symlink (assoc-ref %build-inputs "p1:one") "one")
306 (symlink (assoc-ref %build-inputs "p1:two") "two"))
307 #:inputs `(("p1:one" ,p1 "one")
308 ("p1:two" ,p1 "two"))))
309 (p0g (list (graft
310 (origin p0)
311 (replacement p0r))))
312 (p2d (graft-derivation %store p2 p0g)))
313
314 (build-derivations %store (list p2d))
315 (let ((out (derivation->output-path (pk 'p2d p2d))))
316 (equal? (stat (string-append out "/one/p0/replacement"))
317 (stat (string-append out "/two/link/p0/replacement"))))))
318
319(test-assert "graft-derivation, no applicable grafts"
320 ;; This test verifies that when grafts don't apply to any dependencies,
321 ;; the original derivation is returned unchanged.
322 (let* ((p1 (build-expression->derivation
323 %store "p1"
324 `(let ((one (assoc-ref %outputs "one"))
325 (two (assoc-ref %outputs "two")))
326 (mkdir one)
327 (mkdir two))
328 #:outputs '("one" "two")))
329 (p1r (build-expression->derivation
330 %store "P1"
331 `(let ((other (assoc-ref %outputs "ONE")))
332 (mkdir other)
333 (call-with-output-file (string-append other "/replacement")
334 (const #t)))
335 #:outputs '("ONE")))
336 (p2 (build-expression->derivation
337 %store "p2"
338 `(let ((aaa (assoc-ref %outputs "aaa"))
339 (zzz (assoc-ref %outputs "zzz")))
340 (mkdir zzz) (chdir zzz)
341 (mkdir aaa) (chdir aaa)
342 (symlink (assoc-ref %build-inputs "p1:two") "two"))
343 #:outputs '("aaa" "zzz")
344 #:inputs `(("p1:one" ,p1 "one")
345 ("p1:two" ,p1 "two"))))
346 (p1g (graft
347 (origin p1)
348 (origin-output "one")
349 (replacement p1r)
350 (replacement-output "ONE")))
351 ;; Note: #:outputs parameter removed - now always uses all outputs
352 (p2g (graft-derivation %store p2 (list p1g))))
353 ;; P2:aaa depends on P1:two, but not on P1:one, so nothing to graft.
354 (eq? p2g p2)))
355
356(test-assert "graft-derivation, renaming" ;<http://bugs.gnu.org/23132>
357 (let* ((build `(begin
358 (use-modules (guix build utils))
359 (mkdir-p (string-append (assoc-ref %outputs "out") "/"
360 (assoc-ref %build-inputs "in")))))
361 (orig (build-expression->derivation %store "thing-to-graft" build
362 #:modules '((guix build utils))
363 #:inputs `(("in" ,%bash))))
364 (repl (add-text-to-store %store "bash" "fake bash"))
365 (grafted (graft-derivation %store orig
366 (list (graft
367 (origin %bash)
368 (replacement repl))))))
369 (and (build-derivations %store (list grafted))
370 (let ((out (derivation->output-path grafted)))
371 (file-is-directory? (string-append out "/" repl))))))
372
373(test-assert "graft-derivation, grafts are not shadowed"
374 ;; We build a DAG as below, where dotted arrows represent replacements and
375 ;; solid arrows represent dependencies:
376 ;;
377 ;; P1 ·············> P1R
378 ;; |\__________________.
379 ;; v v
380 ;; P2 ·············> P2R
381 ;; |
382 ;; v
383 ;; P3
384 ;;
385 ;; We want to make sure that the two grafts we want to apply to P3 are
386 ;; honored and not shadowed by other computed grafts.
387 (let* ((p1 (build-expression->derivation
388 %store "p1"
389 '(mkdir (assoc-ref %outputs "out"))))
390 (p1r (build-expression->derivation
391 %store "P1"
392 '(let ((out (assoc-ref %outputs "out")))
393 (mkdir out)
394 (call-with-output-file (string-append out "/replacement")
395 (const #t)))))
396 (p2 (build-expression->derivation
397 %store "p2"
398 `(let ((out (assoc-ref %outputs "out")))
399 (mkdir out)
400 (chdir out)
401 (symlink (assoc-ref %build-inputs "p1") "p1"))
402 #:inputs `(("p1" ,p1))))
403 (p2r (build-expression->derivation
404 %store "P2"
405 `(let ((out (assoc-ref %outputs "out")))
406 (mkdir out)
407 (chdir out)
408 (symlink (assoc-ref %build-inputs "p1") "p1")
409 (call-with-output-file (string-append out "/replacement")
410 (const #t)))
411 #:inputs `(("p1" ,p1))))
412 (p3 (build-expression->derivation
413 %store "p3"
414 `(let ((out (assoc-ref %outputs "out")))
415 (mkdir out)
416 (chdir out)
417 (symlink (assoc-ref %build-inputs "p2") "p2"))
418 #:inputs `(("p2" ,p2))))
419 (p1g (graft
420 (origin p1)
421 (replacement p1r)))
422 (p2g (graft
423 (origin p2)
424 (replacement (graft-derivation %store p2r (list p1g)))))
425 (p3d (graft-derivation %store p3 (list p1g p2g))))
426 (and (build-derivations %store (list p3d))
427 (let ((out (derivation->output-path (pk p3d))))
428 ;; Make sure OUT refers to the replacement of P2, which in turn
429 ;; refers to the replacement of P1, as specified by P1G and P2G.
430 ;; It used to be the case that P2G would be shadowed by a simple
431 ;; P2->P2R graft, which is not what we want.
432 (and (file-exists? (string-append out "/p2/replacement"))
433 (file-exists? (string-append out "/p2/p1/replacement")))))))
434
435(define buffer-size
436 ;; Must be equal to REQUEST-SIZE in 'replace-store-references'.
437 (expt 2 20))
438
439(test-equal "replace-store-references, <http://bugs.gnu.org/28212>"
440 (string-append (make-string (- buffer-size 47) #\a)
441 "/gnu/store/" (make-string 32 #\8)
442 "-SoMeTHiNG"
443 (list->string (map integer->char (iota 77 33))))
444
445 ;; Create input data where the right-hand-size of the dash ("-something"
446 ;; here) goes beyond the end of the internal buffer of
447 ;; 'replace-store-references'.
448 (let* ((content (string-append (make-string (- buffer-size 47) #\a)
449 "/gnu/store/" (make-string 32 #\7)
450 "-something"
451 (list->string
452 (map integer->char (iota 77 33)))))
453 (replacement (alist->vhash
454 `((,(make-string 32 #\7)
455 . ,(string->utf8 (string-append
456 (make-string 32 #\8)
457 "-SoMeTHiNG")))))))
458 (call-with-output-string
459 (lambda (output)
460 ((@@ (guix build graft) replace-store-references)
461 (open-input-string content) output
462 replacement
463 "/gnu/store")))))
464
465(define (insert-nuls char-size str)
466 (string-join (map string (string->list str))
467 (make-string (- char-size 1) #\nul)))
468
469(define (nuls-to-underscores s)
470 (string-replace-substring s "\0" "_"))
471
472(define (annotate-buffer-boundary s)
473 (string-append (string-take s buffer-size)
474 "|"
475 (string-drop s buffer-size)))
476
477(define (abbreviate-leading-fill s)
478 (let ((s* (string-trim s #\=)))
479 (format #f "[~a =s]~a"
480 (- (string-length s)
481 (string-length s*))
482 s*)))
483
484(define (prettify-for-display s)
485 (abbreviate-leading-fill
486 (annotate-buffer-boundary
487 (nuls-to-underscores s))))
488
489(define (two-sample-refs-with-gap char-size1 char-size2 gap offset
490 char1 name1 char2 name2)
491 (string-append
492 (make-string (- buffer-size offset) #\=)
493 (insert-nuls char-size1
494 (string-append "/gnu/store/" (make-string 32 char1) name1))
495 gap
496 (insert-nuls char-size2
497 (string-append "/gnu/store/" (make-string 32 char2) name2))
498 (list->string (map integer->char (iota 77 33)))))
499
500(define (sample-map-entry old-char new-char new-name)
501 (cons (make-string 32 old-char)
502 (string->utf8 (string-append (make-string 32 new-char)
503 new-name))))
504
505(define (test-two-refs-with-gap char-size1 char-size2 gap offset)
506 (test-equal
507 (format #f "test-two-refs-with-gap, char-sizes ~a ~a, gap ~s, offset ~a"
508 char-size1 char-size2 gap offset)
509 (prettify-for-display
510 (two-sample-refs-with-gap char-size1 char-size2 gap offset
511 #\6 "-BlahBlaH"
512 #\8"-SoMeTHiNG"))
513 (prettify-for-display
514 (let* ((content (two-sample-refs-with-gap char-size1 char-size2 gap offset
515 #\5 "-blahblah"
516 #\7 "-something"))
517 (replacement (alist->vhash
518 (list (sample-map-entry #\5 #\6 "-BlahBlaH")
519 (sample-map-entry #\7 #\8 "-SoMeTHiNG")))))
520 (call-with-output-string
521 (lambda (output)
522 ((@@ (guix build graft) replace-store-references)
523 (open-input-string content) output
524 replacement
525 "/gnu/store")))))))
526
527(for-each (lambda (char-size1)
528 (for-each (lambda (char-size2)
529 (for-each (lambda (gap)
530 (for-each (lambda (offset)
531 (test-two-refs-with-gap char-size1
532 char-size2
533 gap
534 offset))
535 ;; offsets to test
536 (map (lambda (i)
537 (+ i (* 40 char-size1)))
538 (iota 30))))
539 ;; gaps
540 '("" "-" " " "a")))
541 ;; char-size2 values to test
542 '(1 2)))
543 ;; char-size1 values to test
544 '(1 2 4))
545
546(test-assert "graft-derivation, multi-output graft determinism"
547 ;; THE BUG: In earlier broken code, cumulative-grafts cached by
548 ;; (drv, outputs, grafts).
549 ;; Same derivation with different outputs -> different cache entries ->
550 ;; different grafted derivations created. This causes runtime crashes:
551 ;;
552 ;; When a process dlopens multiple libraries that depend on the same
553 ;; multi-output package but were grafted with different output sets:
554 ;; - Library A built against grafted-glib-A (only :out output)
555 ;; - Library B built against grafted-glib-B (:out + :bin outputs)
556 ;;
557 ;; At runtime, dlopen loads Library A which loads grafted-glib-A's libglib.so.
558 ;; Then dlopen loads Library B which loads grafted-glib-B's libglib.so.
559 ;; Now two different libglib.so binaries are loaded in the same process!
560 ;;
561 ;; Specific to GLib: The GObject type registry cannot register two objects with
562 ;; the same name. When both glib binaries try to register their types, the
563 ;; second registration fails/conflicts. Result: type registration errors,
564 ;; vtable corruption, and segfaults.
565 ;;
566 ;; THE FIX: Always use ALL outputs when grafting. Only one grafted glib
567 ;; derivation is ever created (with all outputs). The :out output is identical
568 ;; for all consumers, regardless of which outputs they actually use.
569 ;;
570 ;; This test verifies that gtk+ and a direct glib reference use the same
571 ;; glib:out store path.
572 ;;
573 ;; This situation occurs in production when a profile/manifest contains both
574 ;; a library (like gtk+) and that library's dependency (like glib).
575 ;;
576 ;; For example:
577 ;; (packages->manifest (list gtk+ glib))
578 ;; or when a package has both in propagated-inputs:
579 ;; (propagated-inputs (list gtk+ glib))
580 ;;
581 ;; When building the profile, both gtk+ and glib are grafted via
582 ;; package->derivation, causing glib to be processed twice with different
583 ;; output sets.
584 ;;
585 ;; That's because graft-derivation is never (and was never) called with
586 ;; #:outputs--so it defaults to ALL outputs.
587 (let* (;; pcre2 - a dependency of glib
588 (pcre2 (build-expression->derivation
589 %store "pcre2"
590 `(let ((out (assoc-ref %outputs "out")))
591 (use-modules (guix build utils))
592 (mkdir-p (string-append out "/lib"))
593 (call-with-output-file
594 (string-append out "/lib/libpcre2.txt")
595 (lambda (port) (display "pcre2" port))))
596 #:modules '((guix build utils))))
597 ;; Create multi-output glib that depends on pcre2 (like real glib).
598 (glib (build-expression->derivation
599 %store "glib"
600 `(let ((out (assoc-ref %outputs "out"))
601 (bin (assoc-ref %outputs "bin"))
602 (doc (assoc-ref %outputs "doc"))
603 (debug (assoc-ref %outputs "debug"))
604 (pcre2 (assoc-ref %build-inputs "pcre2")))
605 (use-modules (guix build utils))
606 (mkdir-p (string-append out "/lib"))
607 (mkdir-p (string-append bin "/bin"))
608 (mkdir doc)
609 (mkdir-p (string-append debug "/lib/debug"))
610 (call-with-output-file
611 (string-append out "/lib/libglib-2.0.txt")
612 (lambda (port)
613 (display out port)))
614 (symlink (string-append pcre2 "/lib/libpcre2.txt")
615 (string-append out "/pcre2-link"))
616 ;; bin output references "out" output.
617 (call-with-output-file
618 (string-append bin "/bin/glib-compile-schemas")
619 (lambda (port)
620 (display (string-append out "/lib/libglib-2.0.txt")
621 port)))
622 ;; debug output references "bin" output.
623 (call-with-output-file
624 (string-append debug "/lib/debug/glib-bin-path.txt")
625 (lambda (port)
626 (display (string-append bin "/bin/glib-compile-schemas")
627 port))))
628 #:modules '((guix build utils))
629 #:inputs `(("pcre2" ,pcre2))
630 #:outputs '("out" "bin" "doc" "debug")))
631 ;; Create patched glib (security fix) - also depends on pcre2.
632 (glib-patched (build-expression->derivation
633 %store "gliB"
634 `(let ((out (assoc-ref %outputs "out"))
635 (bin (assoc-ref %outputs "bin"))
636 (doc (assoc-ref %outputs "doc"))
637 (debug (assoc-ref %outputs "debug"))
638 (pcre2 (assoc-ref %build-inputs "pcre2")))
639 (use-modules (guix build utils))
640 (mkdir-p (string-append out "/lib"))
641 (mkdir-p (string-append bin "/bin"))
642 (mkdir doc)
643 (mkdir-p (string-append debug "/lib/debug"))
644 (call-with-output-file
645 (string-append out "/lib/libglib-2.0.txt")
646 (lambda (port)
647 (display out port)))
648 (symlink (string-append pcre2 "/lib/libpcre2.txt")
649 (string-append out "/pcre2-link"))
650 ;; bin output references "out" output.
651 (call-with-output-file
652 (string-append bin "/bin/glib-compile-schemas")
653 (lambda (port)
654 (display (string-append out
655 "/lib/libglib-2.0.txt")
656 port)))
657 ;; debug output references "bin" output.
658 (call-with-output-file
659 (string-append debug
660 "/lib/debug/glib-bin-path.txt")
661 (lambda (port)
662 (display (string-append bin
663 "/bin/glib-compile-schemas")
664 port))))
665 #:modules '((guix build utils))
666 #:inputs `(("pcre2" ,pcre2))
667 #:outputs '("out" "bin" "doc" "debug")))
668 ;; gtk+ needs only glib:out.
669 (gtk+ (build-expression->derivation
670 %store "gtk+"
671 `(let ((glib (assoc-ref %build-inputs "glib")))
672 (use-modules (guix build utils))
673 (mkdir-p (string-append %output "/lib"))
674 (call-with-output-file
675 (string-append %output "/lib/libgtk-3.txt")
676 (lambda (port)
677 (display (string-append glib "/lib/libglib-2.0.txt")
678 port))))
679 #:modules '((guix build utils))
680 #:inputs `(("glib" ,glib "out"))))
681 ;; Patched pcre2 (for example security fix).
682 (pcre2-patched (build-expression->derivation
683 %store "Pcre2"
684 `(let ((out (assoc-ref %outputs "out")))
685 (use-modules (guix build utils))
686 (mkdir-p (string-append out "/lib"))
687 (call-with-output-file
688 (string-append out "/lib/libpcre2.txt")
689 (lambda (port)
690 (display "pcre2-patched" port))))
691 #:modules '((guix build utils))))
692 ;; Define graft to fix pcre2 vulnerability (glib's dependency).
693 (pcre2-graft (graft
694 (origin pcre2)
695 (origin-output "out")
696 (replacement pcre2-patched)
697 (replacement-output "out")))
698 ;; FIRST: Graft gtk+ which depends on glib:out.
699 ;; Buggy: gtk+ -> glib with outputs=("out")
700 ;; Cache key: (glib, ("out"), (pcre2-graft))
701 ;; Creates grafted-glib-OUT-ONLY
702 ;; Fixed: Always uses all outputs
703 (gtk-grafted (graft-derivation %store gtk+ (list pcre2-graft)))
704 ;; SECOND: Graft glib directly - uses all outputs by default.
705 ;; Buggy: cumulative-grafts(glib, outputs=ALL)
706 ;; Cache key: (glib, ALL, (pcre2-graft)) - different!
707 ;; Creates grafted-glib-ALL.
708 ;; Fixed: Same cache key as gtk+ path (always ALL).
709 (glib-grafted (graft-derivation %store glib (list pcre2-graft))))
710 ;; Build both grafted derivations
711 (build-derivations %store (list gtk-grafted glib-grafted))
712 (let* (;; Get glib:out path from direct graft
713 (glib-out-direct (derivation->output-path glib-grafted "out"))
714 ;; Get glib:out path from gtk+'s perspective.
715 (gtk-path (derivation->output-path gtk-grafted))
716 (gtk-glib-ref (call-with-input-file
717 (string-append gtk-path "/lib/libgtk-3.txt")
718 get-string-all)))
719 (pk 'glib-out-direct glib-out-direct)
720 (pk 'gtk-glib-ref gtk-glib-ref)
721 ;; BROKEN: gtk+ sees a different glib:out than the direct graft.
722 ;; FIXED: They're the same.
723 (string=? (string-append glib-out-direct "/lib/libglib-2.0.txt")
724 gtk-glib-ref))))
725
726(test-assert "graft-derivation, consistent cache keys"
727 ;; Test that cumulative-grafts produces consistent cache keys regardless
728 ;; of the calling context, preventing bug <https://bugs.gnu.org/75157>.
729 ;;
730 ;; The fix ensures that calling graft-derivation multiple times on the
731 ;; same derivation always produces the same result, regardless of context.
732 (let* (;; Create a multi-output package.
733 (base-pkg (build-expression->derivation
734 %store "base-pkg"
735 `(let ((out (assoc-ref %outputs "out"))
736 (lib (assoc-ref %outputs "lib")))
737 (mkdir out) (mkdir lib)
738 (call-with-output-file (string-append out "/binary")
739 (lambda (port) (display "base-binary" port)))
740 (call-with-output-file (string-append lib "/library")
741 (lambda (port) (display "base-library" port))))
742 #:outputs '("out" "lib")))
743 ;; Create dependency that needs grafting.
744 (dep-orig (build-expression->derivation
745 %store "dep-orig"
746 `(begin (mkdir %output)
747 (call-with-output-file
748 (string-append %output "/data")
749 (lambda (port)
750 (display "vulnerable-data" port))))))
751 (dep-fixed (build-expression->derivation
752 %store "dep-fixed"
753 `(begin (mkdir %output)
754 (call-with-output-file
755 (string-append %output "/data")
756 (lambda (port)
757 (display "secure-data" port))))))
758 ;; Create the multi-output package that depends on the vulnerable dep.
759 (multi-pkg (build-expression->derivation
760 %store "multi-pkg"
761 `(let ((out (assoc-ref %outputs "out"))
762 (lib (assoc-ref %outputs "lib"))
763 (debug (assoc-ref %outputs "debug")))
764 (mkdir out) (mkdir lib) (mkdir debug)
765 ;; Both outputs depend on the vulnerable dependency.
766 (symlink (assoc-ref %build-inputs "dep")
767 (string-append out "/dep-link"))
768 (symlink (assoc-ref %build-inputs "dep")
769 (string-append lib "/dep-link")))
770 #:outputs '("out" "lib" "debug")
771 #:inputs `(("dep" ,dep-orig))))
772 ;; Define graft to fix the vulnerability.
773 (security-graft (graft
774 (origin dep-orig)
775 (replacement dep-fixed)))
776 ;; Scenario 1: Something requests just the "out" output.
777 (result1 (graft-derivation %store multi-pkg (list security-graft)))
778 ;; Scenario 2: Something requests just the "lib" output.
779 (result2 (graft-derivation %store multi-pkg (list security-graft)))
780 ;; Critical test: both scenarios should produce the SAME derivation
781 ;; because cumulative-grafts now uses canonical outputs for caching.
782 (same-result? (equal? result1 result2))
783 ;; Verify the result has all outputs.
784 (has-all-outputs?
785 (and (member "out" (derivation-output-names result1))
786 (member "lib" (derivation-output-names result1))
787 (member "debug" (derivation-output-names result1)))))
788 (and same-result? has-all-outputs?)))
789
790(test-end)