guix/tests/grafts.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2019, 2022-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-grafts)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (guix derivations)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix grafts)
  #:use-module (guix tests)
  #:use-module (gnu packages bootstrap)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 vlist))

(define %store
  (open-connection-for-tests))

;; When grafting, do not add dependency on 'glibc-utf8-locales'.
(%graft-with-utf8-locale? #f)

(define (bootstrap-binary name)
  (let ((bin (search-bootstrap-binary name (%current-system))))
    (and %store
         (add-to-store %store name #t "sha256" bin))))

(define %bash
  (bootstrap-binary "bash"))
(define %mkdir
  (bootstrap-binary "mkdir"))


(test-begin "grafts")

(test-equal "graft-derivation, grafted item is a direct dependency"
  '((type . graft) (graft (count . 2)))
  (let* ((build `(begin
                   (mkdir %output)
                   (chdir %output)
                   (symlink %output "self")
                   (call-with-output-file "text"
                     (lambda (output)
                       (format output "foo/~a/bar" ,%mkdir)))
                   (symlink ,%bash "sh")))
         (orig  (build-expression->derivation %store "grafted" build
                                              #:inputs `(("a" ,%bash)
                                                         ("b" ,%mkdir))))
         (one   (add-text-to-store %store "bash" "fake bash"))
         (two   (build-expression->derivation %store "mkdir"
                                              '(call-with-output-file %output
                                                 (lambda (port)
                                                   (display "fake mkdir" port)))))
         (grafted (graft-derivation %store orig
                                    (list (graft
                                            (origin %bash)
                                            (replacement one))
                                          (graft
                                            (origin %mkdir)
                                            (replacement two))))))
    (and (build-derivations %store (list grafted))
         (let ((properties (derivation-properties grafted))
               (two        (derivation->output-path two))
               (grafted    (derivation->output-path grafted)))
           (and (string=? (format #f "foo/~a/bar" two)
                          (call-with-input-file (string-append grafted "/text")
                            get-string-all))
                (string=? (readlink (string-append grafted "/sh")) one)
                (string=? (readlink (string-append grafted "/self"))
                          grafted)
                properties)))))

(test-assert "graft-derivation, grafted item uses a different name"
  (let* ((build   `(begin
                     (mkdir %output)
                     (chdir %output)
                     (symlink %output "self")
                     (symlink ,%bash "sh")))
         (orig    (build-expression->derivation %store "grafted" build
                                                #:inputs `(("a" ,%bash))))
         (repl    (add-text-to-store %store "BaSH" "fake bash"))
         (grafted (graft-derivation %store orig
                                    (list (graft
                                            (origin %bash)
                                            (replacement repl))))))
    (and (build-derivations %store (list grafted))
         (let ((grafted (derivation->output-path grafted)))
           (and (string=? (readlink (string-append grafted "/sh")) repl)
                (string=? (readlink (string-append grafted "/self"))
                          grafted))))))

;; Make sure 'derivation-file-name' always gets to see an absolute file name.
(fluid-set! %file-port-name-canonicalization 'absolute)

(test-assert "graft-derivation, grafted item is an indirect dependency"
  (let* ((build `(begin
                   (mkdir %output)
                   (chdir %output)
                   (symlink %output "self")
                   (call-with-output-file "text"
                     (lambda (output)
                       (format output "foo/~a/bar" ,%mkdir)))
                   (symlink ,%bash "sh")))
         (dep   (build-expression->derivation %store "dep" build
                                              #:inputs `(("a" ,%bash)
                                                         ("b" ,%mkdir))))
         (orig  (build-expression->derivation %store "thing"
                                              '(symlink
                                                (assoc-ref %build-inputs
                                                           "dep")
                                                %output)
                                              #:inputs `(("dep" ,dep))))
         (one   (add-text-to-store %store "bash" "fake bash"))
         (two   (build-expression->derivation %store "mkdir"
                                              '(call-with-output-file %output
                                                 (lambda (port)
                                                   (display "fake mkdir" port)))))
         (grafted (graft-derivation %store orig
                                    (list (graft
                                            (origin %bash)
                                            (replacement one))
                                          (graft
                                            (origin %mkdir)
                                            (replacement two))))))
    (and (build-derivations %store (list grafted))
         (let* ((two     (derivation->output-path two))
                (grafted (derivation->output-path grafted))
                (dep     (readlink grafted)))
           (and (string=? (format #f "foo/~a/bar" two)
                          (call-with-input-file (string-append dep "/text")
                            get-string-all))
                (string=? (readlink (string-append dep "/sh")) one)
                (string=? (readlink (string-append dep "/self")) dep)
                (equal? (references %store grafted) (list dep))
                (lset= string=?
                       (list one two dep)
                       (references %store dep)))))))

(test-assert "graft-derivation, preserve empty directories"
  (run-with-store %store
    (mlet* %store-monad ((fake    (text-file "bash" "Fake bash."))
                         (graft -> (graft
                                     (origin %bash)
                                     (replacement fake)))
                         (drv     (gexp->derivation
                                   "to-graft"
                                   (with-imported-modules '((guix build utils))
                                     #~(begin
                                         (use-modules (guix build utils))
                                         (mkdir-p (string-append #$output
                                                                 "/a/b/c/d"))
                                         (symlink #$%bash
                                                  (string-append #$output
                                                                 "/bash"))))))
                         (grafted ((store-lift graft-derivation) drv
                                   (list graft)))
                         (_       (built-derivations (list grafted)))
                         (out ->  (derivation->output-path grafted)))
      (return (and (string=? (readlink (string-append out "/bash"))
                             fake)
                   (file-is-directory? (string-append out "/a/b/c/d")))))))

(test-assert "graft-derivation, no dependencies on grafted output"
  (run-with-store %store
    (mlet* %store-monad ((fake    (text-file "bash" "Fake bash."))
                         (graft -> (graft
                                     (origin %bash)
                                     (replacement fake)))
                         (drv     (gexp->derivation "foo" #~(mkdir #$output)))
                         (grafted ((store-lift graft-derivation) drv
                                   (list graft))))
      (return (eq? grafted drv)))))

(test-assert "graft-derivation, multiple outputs"
  (let* ((build `(begin
                   (symlink (assoc-ref %build-inputs "a")
                            (assoc-ref %outputs "one"))
                   (symlink (assoc-ref %outputs "one")
                            (assoc-ref %outputs "two"))))
         (orig  (build-expression->derivation %store "grafted" build
                                              #:inputs `(("a" ,%bash))
                                              #:outputs '("one" "two")))
         (repl  (add-text-to-store %store "bash" "fake bash"))
         (grafted (graft-derivation %store orig
                                    (list (graft
                                            (origin %bash)
                                            (replacement repl))))))
    (and (build-derivations %store (list grafted))
         (let ((one (derivation->output-path grafted "one"))
               (two (derivation->output-path grafted "two")))
           (and (string=? (readlink one) repl)
                (string=? (readlink two) one))))))

(test-assert "graft-derivation, replaced derivation has multiple outputs"
  ;; Here we have a replacement just for output "one" of P1 and not for the
  ;; other output.  Make sure the graft for P1:one correctly applies to the
  ;; dependents of P1.  See <http://bugs.gnu.org/24712>.
  (let* ((p1  (build-expression->derivation
               %store "p1"
               `(let ((one (assoc-ref %outputs "one"))
                      (two (assoc-ref %outputs "two")))
                  (mkdir one)
                  (mkdir two))
               #:outputs '("one" "two")))
         (p1r (build-expression->derivation
               %store "P1"
               `(let ((other (assoc-ref %outputs "ONE")))
                  (mkdir other)
                  (call-with-output-file (string-append other "/replacement")
                    (const #t)))
               #:outputs '("ONE")))
         (p2  (build-expression->derivation
               %store "p2"
               `(let ((out (assoc-ref %outputs "aaa")))
                  (mkdir (assoc-ref %outputs "zzz"))
                  (mkdir out) (chdir out)
                  (symlink (assoc-ref %build-inputs "p1:one") "one")
                  (symlink (assoc-ref %build-inputs "p1:two") "two"))
               #:outputs '("aaa" "zzz")
               #:inputs `(("p1:one" ,p1 "one")
                          ("p1:two" ,p1 "two"))))
         (p3  (build-expression->derivation
               %store "p3"
               `(symlink (assoc-ref %build-inputs "p2:aaa")
                         (assoc-ref %outputs "out"))
               #:inputs `(("p2:aaa" ,p2 "aaa")
                          ("p2:zzz" ,p2 "zzz"))))
         (p1g (graft
                (origin p1)
                (origin-output "one")
                (replacement p1r)
                (replacement-output "ONE")))
         (p3d (graft-derivation %store p3 (list p1g))))

    (and (not (find (lambda (input)
                      ;; INPUT should not be P2:zzz since the result of P3
                      ;; does not depend on it.  See
                      ;; <http://bugs.gnu.org/24886>.
                      (and (string=? (derivation-input-path input)
                                     (derivation-file-name p2))
                           (member "zzz"
                                   (derivation-input-sub-derivations input))))
                    (derivation-inputs p3d)))

         (build-derivations %store (list p3d))
         (let ((out (derivation->output-path (pk 'p2d p3d))))
           (and (not (string=? (readlink out)
                               (derivation->output-path p2 "aaa")))
                (string=? (derivation->output-path p1 "two")
                          (readlink (string-append out "/two")))
                (file-exists? (string-append out "/one/replacement")))))))

(test-assert "graft-derivation, multiple outputs need to be replaced"
  ;; Build a reference graph like this:
  ;;
  ;;         ,- p2:out --.
  ;;         v           v
  ;;      p1:one <---- p1:two
  ;;         |
  ;;         `-> p0
  ;;
  ;; Graft p0r in lieu of p0, and make sure all the paths from the grafted p2
  ;; lead to p0r.  See <https://issues.guix.gnu.org/66662>.
  (let* ((p0  (build-expression->derivation
               %store "p0" '(mkdir (assoc-ref %outputs "out"))))
         (p0r (build-expression->derivation
               %store "P0"
               '(let ((out (assoc-ref %outputs "out")))
                  (mkdir out)
                  (call-with-output-file (string-append out "/replacement")
                    (const #t)))))
         (p1  (build-expression->derivation
               %store "p1"
               `(let ((one (assoc-ref %outputs "one"))
                      (two (assoc-ref %outputs "two"))
                      (p0  (assoc-ref %build-inputs "p0")))
                  (mkdir one)
                  (mkdir two)
                  (symlink p0 (string-append one "/p0"))
                  (symlink one (string-append two "/link")))
               #:inputs `(("p0" ,p0))
               #:outputs '("one" "two")))
         (p2  (build-expression->derivation
               %store "p2"
               `(let ((out (assoc-ref %outputs "out")))
                  (mkdir out) (chdir out)
                  (symlink (assoc-ref %build-inputs "p1:one") "one")
                  (symlink (assoc-ref %build-inputs "p1:two") "two"))
               #:inputs `(("p1:one" ,p1 "one")
                          ("p1:two" ,p1 "two"))))
         (p0g (list (graft
                      (origin p0)
                      (replacement p0r))))
         (p2d (graft-derivation %store p2 p0g)))

    (build-derivations %store (list p2d))
    (let ((out (derivation->output-path (pk 'p2d p2d))))
      (equal? (stat (string-append out "/one/p0/replacement"))
              (stat (string-append out "/two/link/p0/replacement"))))))

(test-assert "graft-derivation, no applicable grafts"
  ;; This test verifies that when grafts don't apply to any dependencies,
  ;; the original derivation is returned unchanged.
  (let* ((p1  (build-expression->derivation
               %store "p1"
               `(let ((one (assoc-ref %outputs "one"))
                      (two (assoc-ref %outputs "two")))
                  (mkdir one)
                  (mkdir two))
               #:outputs '("one" "two")))
         (p1r (build-expression->derivation
               %store "P1"
               `(let ((other (assoc-ref %outputs "ONE")))
                  (mkdir other)
                  (call-with-output-file (string-append other "/replacement")
                    (const #t)))
               #:outputs '("ONE")))
         (p2  (build-expression->derivation
               %store "p2"
               `(let ((aaa (assoc-ref %outputs "aaa"))
                      (zzz (assoc-ref %outputs "zzz")))
                  (mkdir zzz) (chdir zzz)
                  (mkdir aaa) (chdir aaa)
                  (symlink (assoc-ref %build-inputs "p1:two") "two"))
               #:outputs '("aaa" "zzz")
               #:inputs `(("p1:one" ,p1 "one")
                          ("p1:two" ,p1 "two"))))
         (p1g (graft
                (origin p1)
                (origin-output "one")
                (replacement p1r)
                (replacement-output "ONE")))
         ;; Note: #:outputs parameter removed - now always uses all outputs
         (p2g (graft-derivation %store p2 (list p1g))))
    ;; P2:aaa depends on P1:two, but not on P1:one, so nothing to graft.
    (eq? p2g p2)))

(test-assert "graft-derivation, renaming"         ;<http://bugs.gnu.org/23132>
  (let* ((build `(begin
                   (use-modules (guix build utils))
                   (mkdir-p (string-append (assoc-ref %outputs "out") "/"
                                           (assoc-ref %build-inputs "in")))))
         (orig  (build-expression->derivation %store "thing-to-graft" build
                                              #:modules '((guix build utils))
                                              #:inputs `(("in" ,%bash))))
         (repl  (add-text-to-store %store "bash" "fake bash"))
         (grafted (graft-derivation %store orig
                                    (list (graft
                                            (origin %bash)
                                            (replacement repl))))))
    (and (build-derivations %store (list grafted))
         (let ((out (derivation->output-path grafted)))
           (file-is-directory? (string-append out "/" repl))))))

(test-assert "graft-derivation, grafts are not shadowed"
  ;; We build a DAG as below, where dotted arrows represent replacements and
  ;; solid arrows represent dependencies:
  ;;
  ;;  P1  ·············>  P1R
  ;;  |\__________________.
  ;;  v                   v
  ;;  P2  ·············>  P2R
  ;;  |
  ;;  v
  ;;  P3
  ;;
  ;; We want to make sure that the two grafts we want to apply to P3 are
  ;; honored and not shadowed by other computed grafts.
  (let* ((p1     (build-expression->derivation
                  %store "p1"
                  '(mkdir (assoc-ref %outputs "out"))))
         (p1r    (build-expression->derivation
                  %store "P1"
                  '(let ((out (assoc-ref %outputs "out")))
                     (mkdir out)
                     (call-with-output-file (string-append out "/replacement")
                       (const #t)))))
         (p2     (build-expression->derivation
                  %store "p2"
                  `(let ((out (assoc-ref %outputs "out")))
                     (mkdir out)
                     (chdir out)
                     (symlink (assoc-ref %build-inputs "p1") "p1"))
                  #:inputs `(("p1" ,p1))))
         (p2r    (build-expression->derivation
                  %store "P2"
                  `(let ((out (assoc-ref %outputs "out")))
                     (mkdir out)
                     (chdir out)
                     (symlink (assoc-ref %build-inputs "p1") "p1")
                     (call-with-output-file (string-append out "/replacement")
                       (const #t)))
                  #:inputs `(("p1" ,p1))))
         (p3     (build-expression->derivation
                  %store "p3"
                  `(let ((out (assoc-ref %outputs "out")))
                     (mkdir out)
                     (chdir out)
                     (symlink (assoc-ref %build-inputs "p2") "p2"))
                  #:inputs `(("p2" ,p2))))
         (p1g    (graft
                   (origin p1)
                   (replacement p1r)))
         (p2g    (graft
                   (origin p2)
                   (replacement (graft-derivation %store p2r (list p1g)))))
         (p3d    (graft-derivation %store p3 (list p1g p2g))))
    (and (build-derivations %store (list p3d))
         (let ((out (derivation->output-path (pk p3d))))
           ;; Make sure OUT refers to the replacement of P2, which in turn
           ;; refers to the replacement of P1, as specified by P1G and P2G.
           ;; It used to be the case that P2G would be shadowed by a simple
           ;; P2->P2R graft, which is not what we want.
           (and (file-exists? (string-append out "/p2/replacement"))
                (file-exists? (string-append out "/p2/p1/replacement")))))))

(define buffer-size
  ;; Must be equal to REQUEST-SIZE in 'replace-store-references'.
  (expt 2 20))

(test-equal "replace-store-references, <http://bugs.gnu.org/28212>"
  (string-append (make-string (- buffer-size 47) #\a)
                 "/gnu/store/" (make-string 32 #\8)
                 "-SoMeTHiNG"
                 (list->string (map integer->char (iota 77 33))))

  ;; Create input data where the right-hand-size of the dash ("-something"
  ;; here) goes beyond the end of the internal buffer of
  ;; 'replace-store-references'.
  (let* ((content     (string-append (make-string (- buffer-size 47) #\a)
                                     "/gnu/store/" (make-string 32 #\7)
                                     "-something"
                                     (list->string
                                      (map integer->char (iota 77 33)))))
         (replacement (alist->vhash
                       `((,(make-string 32 #\7)
                          . ,(string->utf8 (string-append
                                            (make-string 32 #\8)
                                            "-SoMeTHiNG")))))))
    (call-with-output-string
      (lambda (output)
        ((@@ (guix build graft) replace-store-references)
         (open-input-string content) output
         replacement
         "/gnu/store")))))

(define (insert-nuls char-size str)
  (string-join (map string (string->list str))
               (make-string (- char-size 1) #\nul)))

(define (nuls-to-underscores s)
  (string-replace-substring s "\0" "_"))

(define (annotate-buffer-boundary s)
  (string-append (string-take s buffer-size)
                 "|"
                 (string-drop s buffer-size)))

(define (abbreviate-leading-fill s)
  (let ((s* (string-trim s #\=)))
    (format #f "[~a =s]~a"
            (- (string-length s)
               (string-length s*))
            s*)))

(define (prettify-for-display s)
  (abbreviate-leading-fill
   (annotate-buffer-boundary
    (nuls-to-underscores s))))

(define (two-sample-refs-with-gap char-size1 char-size2 gap offset
                                  char1 name1 char2 name2)
  (string-append
   (make-string (- buffer-size offset) #\=)
   (insert-nuls char-size1
                (string-append "/gnu/store/" (make-string 32 char1) name1))
   gap
   (insert-nuls char-size2
                (string-append "/gnu/store/" (make-string 32 char2) name2))
   (list->string (map integer->char (iota 77 33)))))

(define (sample-map-entry old-char new-char new-name)
  (cons (make-string 32 old-char)
        (string->utf8 (string-append (make-string 32 new-char)
                                     new-name))))

(define (test-two-refs-with-gap char-size1 char-size2 gap offset)
  (test-equal
      (format #f "test-two-refs-with-gap, char-sizes ~a ~a, gap ~s, offset ~a"
              char-size1 char-size2 gap offset)
    (prettify-for-display
     (two-sample-refs-with-gap char-size1 char-size2 gap offset
                               #\6 "-BlahBlaH"
                               #\8"-SoMeTHiNG"))
    (prettify-for-display
     (let* ((content (two-sample-refs-with-gap char-size1 char-size2 gap offset
                                               #\5 "-blahblah"
                                               #\7 "-something"))
            (replacement (alist->vhash
                          (list (sample-map-entry #\5 #\6 "-BlahBlaH")
                                (sample-map-entry #\7 #\8 "-SoMeTHiNG")))))
       (call-with-output-string
         (lambda (output)
           ((@@ (guix build graft) replace-store-references)
            (open-input-string content) output
            replacement
            "/gnu/store")))))))

(for-each (lambda (char-size1)
            (for-each (lambda (char-size2)
                        (for-each (lambda (gap)
                                    (for-each (lambda (offset)
                                                (test-two-refs-with-gap char-size1
                                                                        char-size2
                                                                        gap
                                                                        offset))
                                              ;; offsets to test
                                              (map (lambda (i)
                                                     (+ i (* 40 char-size1)))
                                                   (iota 30))))
                                  ;; gaps
                                  '("" "-" " " "a")))
                      ;; char-size2 values to test
                      '(1 2)))
          ;; char-size1 values to test
          '(1 2 4))

(test-assert "graft-derivation, multi-output graft determinism"
  ;; THE BUG: In earlier broken code, cumulative-grafts cached by
  ;; (drv, outputs, grafts).
  ;; Same derivation with different outputs -> different cache entries ->
  ;; different grafted derivations created.  This causes runtime crashes:
  ;;
  ;; When a process dlopens multiple libraries that depend on the same
  ;; multi-output package but were grafted with different output sets:
  ;;   - Library A built against grafted-glib-A (only :out output)
  ;;   - Library B built against grafted-glib-B (:out + :bin outputs)
  ;;
  ;; At runtime, dlopen loads Library A which loads grafted-glib-A's libglib.so.
  ;; Then dlopen loads Library B which loads grafted-glib-B's libglib.so.
  ;; Now two different libglib.so binaries are loaded in the same process!
  ;;
  ;; Specific to GLib: The GObject type registry cannot register two objects with
  ;; the same name.  When both glib binaries try to register their types, the
  ;; second registration fails/conflicts.  Result: type registration errors,
  ;; vtable corruption, and segfaults.
  ;;
  ;; THE FIX: Always use ALL outputs when grafting.  Only one grafted glib
  ;; derivation is ever created (with all outputs).  The :out output is identical
  ;; for all consumers, regardless of which outputs they actually use.
  ;;
  ;; This test verifies that gtk+ and a direct glib reference use the same
  ;; glib:out store path.
  ;;
  ;; This situation occurs in production when a profile/manifest contains both
  ;; a library (like gtk+) and that library's dependency (like glib).
  ;;
  ;; For example:
  ;;   (packages->manifest (list gtk+ glib))
  ;; or when a package has both in propagated-inputs:
  ;;   (propagated-inputs (list gtk+ glib))
  ;;
  ;; When building the profile, both gtk+ and glib are grafted via
  ;; package->derivation, causing glib to be processed twice with different
  ;; output sets.
  ;;
  ;; That's because graft-derivation is never (and was never) called with
  ;; #:outputs--so it defaults to ALL outputs.
  (let* (;; pcre2 - a dependency of glib
         (pcre2 (build-expression->derivation
                 %store "pcre2"
                 `(let ((out (assoc-ref %outputs "out")))
                    (use-modules (guix build utils))
                    (mkdir-p (string-append out "/lib"))
                    (call-with-output-file
                     (string-append out "/lib/libpcre2.txt")
                     (lambda (port) (display "pcre2" port))))
                 #:modules '((guix build utils))))
         ;; Create multi-output glib that depends on pcre2 (like real glib).
         (glib (build-expression->derivation
                %store "glib"
                `(let ((out (assoc-ref %outputs "out"))
                       (bin (assoc-ref %outputs "bin"))
                       (doc (assoc-ref %outputs "doc"))
                       (debug (assoc-ref %outputs "debug"))
                       (pcre2 (assoc-ref %build-inputs "pcre2")))
                   (use-modules (guix build utils))
                   (mkdir-p (string-append out "/lib"))
                   (mkdir-p (string-append bin "/bin"))
                   (mkdir doc)
                   (mkdir-p (string-append debug "/lib/debug"))
                   (call-with-output-file
                    (string-append out "/lib/libglib-2.0.txt")
                    (lambda (port)
                      (display out port)))
                   (symlink (string-append pcre2 "/lib/libpcre2.txt")
                            (string-append out "/pcre2-link"))
                   ;; bin output references "out" output.
                   (call-with-output-file
                    (string-append bin "/bin/glib-compile-schemas")
                    (lambda (port)
                      (display (string-append out "/lib/libglib-2.0.txt")
                               port)))
                   ;; debug output references "bin" output.
                   (call-with-output-file
                    (string-append debug "/lib/debug/glib-bin-path.txt")
                    (lambda (port)
                      (display (string-append bin "/bin/glib-compile-schemas")
                               port))))
                #:modules '((guix build utils))
                #:inputs `(("pcre2" ,pcre2))
                #:outputs '("out" "bin" "doc" "debug")))
         ;; Create patched glib (security fix) - also depends on pcre2.
         (glib-patched (build-expression->derivation
                        %store "gliB"
                        `(let ((out (assoc-ref %outputs "out"))
                               (bin (assoc-ref %outputs "bin"))
                               (doc (assoc-ref %outputs "doc"))
                               (debug (assoc-ref %outputs "debug"))
                               (pcre2 (assoc-ref %build-inputs "pcre2")))
                           (use-modules (guix build utils))
                           (mkdir-p (string-append out "/lib"))
                           (mkdir-p (string-append bin "/bin"))
                           (mkdir doc)
                           (mkdir-p (string-append debug "/lib/debug"))
                           (call-with-output-file
                            (string-append out "/lib/libglib-2.0.txt")
                             (lambda (port)
                               (display out port)))
                           (symlink (string-append pcre2 "/lib/libpcre2.txt")
                                    (string-append out "/pcre2-link"))
                           ;; bin output references "out" output.
                           (call-with-output-file
                             (string-append bin "/bin/glib-compile-schemas")
                             (lambda (port)
                               (display (string-append out
                                         "/lib/libglib-2.0.txt")
                                        port)))
                           ;; debug output references "bin" output.
                           (call-with-output-file
                            (string-append debug
                                           "/lib/debug/glib-bin-path.txt")
                            (lambda (port)
                              (display (string-append bin
                                        "/bin/glib-compile-schemas")
                                       port))))
                        #:modules '((guix build utils))
                        #:inputs `(("pcre2" ,pcre2))
                        #:outputs '("out" "bin" "doc" "debug")))
         ;; gtk+ needs only glib:out.
         (gtk+ (build-expression->derivation
                %store "gtk+"
                `(let ((glib (assoc-ref %build-inputs "glib")))
                   (use-modules (guix build utils))
                   (mkdir-p (string-append %output "/lib"))
                   (call-with-output-file
                    (string-append %output "/lib/libgtk-3.txt")
                    (lambda (port)
                      (display (string-append glib "/lib/libglib-2.0.txt")
                               port))))
                #:modules '((guix build utils))
                #:inputs `(("glib" ,glib "out"))))
         ;; Patched pcre2 (for example security fix).
         (pcre2-patched (build-expression->derivation
                         %store "Pcre2"
                         `(let ((out (assoc-ref %outputs "out")))
                            (use-modules (guix build utils))
                            (mkdir-p (string-append out "/lib"))
                            (call-with-output-file
                             (string-append out "/lib/libpcre2.txt")
                             (lambda (port)
                               (display "pcre2-patched" port))))
                         #:modules '((guix build utils))))
         ;; Define graft to fix pcre2 vulnerability (glib's dependency).
         (pcre2-graft (graft
                       (origin pcre2)
                       (origin-output "out")
                       (replacement pcre2-patched)
                       (replacement-output "out")))
         ;; FIRST: Graft gtk+ which depends on glib:out.
         ;; Buggy: gtk+ -> glib with outputs=("out")
         ;;        Cache key: (glib, ("out"), (pcre2-graft))
         ;;        Creates grafted-glib-OUT-ONLY
         ;; Fixed: Always uses all outputs
         (gtk-grafted (graft-derivation %store gtk+ (list pcre2-graft)))
         ;; SECOND: Graft glib directly - uses all outputs by default.
         ;; Buggy: cumulative-grafts(glib, outputs=ALL)
         ;;        Cache key: (glib, ALL, (pcre2-graft)) - different!
         ;;        Creates grafted-glib-ALL.
         ;; Fixed: Same cache key as gtk+ path (always ALL).
         (glib-grafted (graft-derivation %store glib (list pcre2-graft))))
    ;; Build both grafted derivations
    (build-derivations %store (list gtk-grafted glib-grafted))
    (let* (;; Get glib:out path from direct graft
           (glib-out-direct (derivation->output-path glib-grafted "out"))
           ;; Get glib:out path from gtk+'s perspective.
           (gtk-path (derivation->output-path gtk-grafted))
           (gtk-glib-ref (call-with-input-file
                          (string-append gtk-path "/lib/libgtk-3.txt")
                          get-string-all)))
      (pk 'glib-out-direct glib-out-direct)
      (pk 'gtk-glib-ref gtk-glib-ref)
      ;; BROKEN: gtk+ sees a different glib:out than the direct graft.
      ;; FIXED: They're the same.
      (string=? (string-append glib-out-direct "/lib/libglib-2.0.txt")
                gtk-glib-ref))))

(test-assert "graft-derivation, consistent cache keys"
  ;; Test that cumulative-grafts produces consistent cache keys regardless
  ;; of the calling context, preventing bug <https://bugs.gnu.org/75157>.
  ;;
  ;; The fix ensures that calling graft-derivation multiple times on the
  ;; same derivation always produces the same result, regardless of context.
  (let* (;; Create a multi-output package.
         (base-pkg (build-expression->derivation
                    %store "base-pkg"
                    `(let ((out (assoc-ref %outputs "out"))
                           (lib (assoc-ref %outputs "lib")))
                       (mkdir out) (mkdir lib)
                       (call-with-output-file (string-append out "/binary")
                         (lambda (port) (display "base-binary" port)))
                       (call-with-output-file (string-append lib "/library")
                         (lambda (port) (display "base-library" port))))
                    #:outputs '("out" "lib")))
         ;; Create dependency that needs grafting.
         (dep-orig (build-expression->derivation
                    %store "dep-orig"
                    `(begin (mkdir %output)
                            (call-with-output-file
                             (string-append %output "/data")
                              (lambda (port)
                                (display "vulnerable-data" port))))))
         (dep-fixed (build-expression->derivation
                     %store "dep-fixed"
                     `(begin (mkdir %output)
                             (call-with-output-file
                              (string-append %output "/data")
                               (lambda (port)
                                 (display "secure-data" port))))))
         ;; Create the multi-output package that depends on the vulnerable dep.
         (multi-pkg (build-expression->derivation
                     %store "multi-pkg"
                     `(let ((out (assoc-ref %outputs "out"))
                            (lib (assoc-ref %outputs "lib"))
                            (debug (assoc-ref %outputs "debug")))
                        (mkdir out) (mkdir lib) (mkdir debug)
                        ;; Both outputs depend on the vulnerable dependency.
                        (symlink (assoc-ref %build-inputs "dep")
                                 (string-append out "/dep-link"))
                        (symlink (assoc-ref %build-inputs "dep")
                                 (string-append lib "/dep-link")))
                     #:outputs '("out" "lib" "debug")
                     #:inputs `(("dep" ,dep-orig))))
         ;; Define graft to fix the vulnerability.
         (security-graft (graft
                          (origin dep-orig)
                          (replacement dep-fixed)))
         ;; Scenario 1: Something requests just the "out" output.
         (result1 (graft-derivation %store multi-pkg (list security-graft)))
         ;; Scenario 2: Something requests just the "lib" output.
         (result2 (graft-derivation %store multi-pkg (list security-graft)))
         ;; Critical test: both scenarios should produce the SAME derivation
         ;; because cumulative-grafts now uses canonical outputs for caching.
         (same-result? (equal? result1 result2))
         ;; Verify the result has all outputs.
         (has-all-outputs?
          (and (member "out" (derivation-output-names result1))
               (member "lib" (derivation-output-names result1))
               (member "debug" (derivation-output-names result1)))))
    (and same-result? has-all-outputs?)))

(test-end)