Subject: [bug#55231] [PATCH v7 4/4] Propagate non-substitutability of derivations.

From: Morgan Arnold <[email-masked]>
Date: Mon, 17 Feb 2025 14:35:13 +0000

This commit changes the conditions under which derivations, as
constructed by the `derivation' procedure, are made substitutable, to
prevent potential copyright violations related to the construction of
substitutable initrds including non-substitutable derivations (in
particular, ZFS).

This change prevents such copyright violations by only marking a derivation as
substitutable if it is itself marked substitutable along all of its inputs.
This means that non-substitutable derivations propagate to other derivations
using them as input.

Change-Id: I80ba4a371ee0c55a1294aff311d4e7b151055fac
Signed-off-by: Maxim Cournoyer <[email-masked]>
Modified-by: Maxim Cournoyer <[email-masked]>
---
 gnu/system/linux-initrd.scm |  3 +-
 guix/derivations.scm        | 59 +++++++++++++++++++++----------------
 tests/derivations.scm       | 16 +++++-----
 3 files changed, 44 insertions(+), 34 deletions(-)

diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index a8df905..98a4c6e 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -117,7 +117,8 @@ (define* (expression->initrd exp
 
   (file-append (computed-file name builder
                               #:options
-                              `(#:references-graphs (("closure" ,init))))
+                              `(#:references-graphs (("closure" ,init))
+                                #:propagating-substitutable? #t))
                "/initrd.cpio.gz"))
 
 (define (flat-linux-module-directory packages modules)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index ffa69e9..7682c90 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -804,6 +804,7 @@ (define* (derivation store name builder args
                      allowed-references disallowed-references
                      leaked-env-vars local-build?
                      (substitutable? #t)
+                     (propagating-substitutable? #f)
                      (properties '())
                      (%deprecation-warning? #t))
   "Build a derivation with the given arguments, and return the resulting
@@ -832,7 +833,9 @@ (define* (derivation store name builder args
 derivations where the costs of data transfers would outweigh the benefits.
 
 When SUBSTITUTABLE? is false, declare that substitutes of the derivation's
-output should not be used.
+output should not be used. When PROPAGATING-SUBSTITUTABLE? is true, declare
+that substitutes of the derivation's output should not be used if any of the
+derivation's inputs are not substitutable.
 
 PROPERTIES must be an association list describing \"properties\" of the
 derivation.  It is kept as-is, uninterpreted, in the derivation."
@@ -868,33 +871,37 @@ (define* (derivation store name builder args
                                env-vars)
                           #f)))))
 
-  (define (user+system-env-vars)
+  (define (user+system-env-vars inputs)
     ;; Some options are passed to the build daemon via the env. vars of
     ;; derivations (urgh!).  We hide that from our API, but here is the place
     ;; where we kludgify those options.
-    (let ((env-vars `(,@(if local-build?
-                            `(("preferLocalBuild" . "1"))
-                            '())
-                      ,@(if (not substitutable?)
-                            `(("allowSubstitutes" . "0"))
-                            '())
-                      ,@(if allowed-references
-                            `(("allowedReferences"
-                               . ,(string-join allowed-references)))
-                            '())
-                      ,@(if disallowed-references
-                            `(("disallowedReferences"
-                               . ,(string-join disallowed-references)))
-                            '())
-                      ,@(if leaked-env-vars
-                            `(("impureEnvVars"
-                               . ,(string-join leaked-env-vars)))
-                            '())
-                      ,@(match properties
-                          (() '())
-                          (lst `(("guix properties"
-                                  . ,(object->string properties)))))
-                      ,@env-vars)))
+    (let* ((substitutable-inputs? (every substitutable-derivation?
+                                         (map derivation-input-derivation
+                                              inputs)))
+           (env-vars `(,@(if local-build?
+                             `(("preferLocalBuild" . "1"))
+                             '())
+                       ,@(if (and substitutable? (or (not propagating-substitutable?)
+                                                          substitutable-inputs?))
+                             '()
+                             `(("allowSubstitutes" . "0")))
+                       ,@(if allowed-references
+                             `(("allowedReferences"
+                                . ,(string-join allowed-references)))
+                             '())
+                       ,@(if disallowed-references
+                             `(("disallowedReferences"
+                                . ,(string-join disallowed-references)))
+                             '())
+                       ,@(if leaked-env-vars
+                             `(("impureEnvVars"
+                                . ,(string-join leaked-env-vars)))
+                             '())
+                       ,@(match properties
+                           (() '())
+                           (lst `(("guix properties"
+                                   . ,(object->string properties)))))
+                       ,@env-vars)))
       (match references-graphs
         (((file . path) ...)
          (let ((value (map (cut string-append <> " " <>)
@@ -967,7 +974,7 @@ (define* (derivation store name builder args
                             (filter-map input->derivation-input inputs))
                            derivation-input<?))
          (env-vars   (sort (env-vars-with-empty-outputs
-                            (user+system-env-vars))
+                            (user+system-env-vars inputs))
                            (lambda (e1 e2)
                              (string<? (car e1) (car e2)))))
          (drv-masked (make-derivation outputs inputs sources
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 72ea9aa..c157128 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -1105,14 +1105,16 @@ (define %coreutils
         (let-values (((build download)
                       (derivation-build-plan store
                                              (list (derivation-input drv2)))))
-          ;; Although DRV2 is available as a substitute, we must build its
-          ;; dependency, DRV1, due to #:substitutable? #f.
-          (and (match download
-                 (((= substitutable-path item))
-                  (string=? item (derivation->output-path drv2))))
+          ;; DRV2 is *not* available as a substitute, since it has drv1 as
+          ;; input, and the non-substitutability is viral to avoid
+          ;; distributing non-substitutable items that could have become
+          ;; embedded, for example in an initrd.
+          (and (null? download)
                (match build
-                 (((= derivation-file-name build))
-                  (string=? build (derivation-file-name drv1))))))))))
+                 (((= derivation-file-name build1)
+                   (= derivation-file-name build2))
+                  (string=? build1 (derivation-file-name drv1))
+                  (string=? build2 (derivation-file-name drv2))))))))))
 
 (test-assert "derivation-build-plan and substitutes, local build"
   (with-store store
-- 
2.47.1