[bug#55231,v7,4/4] Propagate non-substitutability of derivations.
Commit Message
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 <maxim.cournoyer@gmail.com>
Modified-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>
---
gnu/system/linux-initrd.scm | 3 +-
guix/derivations.scm | 59 +++++++++++++++++++++----------------
tests/derivations.scm | 16 +++++-----
3 files changed, 44 insertions(+), 34 deletions(-)
@@ -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)
@@ -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
@@ -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