diff options
author | Ludovic Courtès <ludo@gnu.org> | 2013-01-09 08:38:57 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2013-01-09 08:38:57 +0100 |
commit | 784bb1f37bfe7efd0c31fdcf207b0459f4edc7bf (patch) | |
tree | 88a40721eede3fca270c792770e06ad1b82bb0af | |
parent | 98fefb210a8b355306de20d3afe5d02dd31a5cbf (diff) | |
download | patches-784bb1f37bfe7efd0c31fdcf207b0459f4edc7bf.tar patches-784bb1f37bfe7efd0c31fdcf207b0459f4edc7bf.tar.gz |
derivations: Fix `derivation-prerequisites-to-build' when outputs are there.
Before it would list inputs not built, even if the outputs of the given
derivation were already available.
* guix/derivations.scm (derivation-prerequisites-to-build): Add
`outputs' keyword parameter.
[built?, derivation-built?]: New procedures.
[loop]: Add `sub-drvs' parameter. Use `derivation-built?' to check if
the SUB-DRVS of DRV are built before checking its inputs.
-rw-r--r-- | guix/derivations.scm | 52 | ||||
-rw-r--r-- | tests/derivations.scm | 38 |
2 files changed, 74 insertions, 16 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm index 7b131955b0..ce8858a2fa 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -112,28 +112,48 @@ download with a fixed hash (aka. `fetchurl')." read-derivation)) inputs))))) -(define (derivation-prerequisites-to-build store drv) - "Return the list of derivation-inputs required to build DRV and not already -available in STORE, recursively." +(define* (derivation-prerequisites-to-build store drv + #:key (outputs + (map + car + (derivation-outputs drv)))) + "Return the list of derivation-inputs required to build the OUTPUTS of +DRV and not already available in STORE, recursively." + (define built? + (cut valid-path? store <>)) + (define input-built? (match-lambda (($ <derivation-input> path sub-drvs) (let ((out (map (cut derivation-path->output-path path <>) sub-drvs))) - (any (cut valid-path? store <>) out))))) + (any built? out))))) - (let loop ((drv drv) - (result '())) - (let ((inputs (remove (lambda (i) - (or (member i result) ; XXX: quadratic - (input-built? i))) - (derivation-inputs drv)))) - (fold loop - (append inputs result) - (map (lambda (i) - (call-with-input-file (derivation-input-path i) - read-derivation)) - inputs))))) + (define (derivation-built? drv sub-drvs) + (match drv + (($ <derivation> outputs) + (let ((paths (map (lambda (sub-drv) + (derivation-output-path + (assoc-ref outputs sub-drv))) + sub-drvs))) + (every built? paths))))) + + (let loop ((drv drv) + (sub-drvs outputs) + (result '())) + (if (derivation-built? drv sub-drvs) + result + (let ((inputs (remove (lambda (i) + (or (member i result) ; XXX: quadratic + (input-built? i))) + (derivation-inputs drv)))) + (fold loop + (append inputs result) + (map (lambda (i) + (call-with-input-file (derivation-input-path i) + read-derivation)) + inputs) + (map derivation-input-sub-derivations inputs)))))) (define (read-derivation drv-port) "Read the derivation from DRV-PORT and return the corresponding diff --git a/tests/derivations.scm b/tests/derivations.scm index 061a9bd42b..119edfcb86 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -353,6 +353,44 @@ ;; built. (null? (derivation-prerequisites-to-build %store drv)))) +(test-assert "derivation-prerequisites-to-build when outputs already present" + (let*-values (((builder) + '(begin (mkdir %output) #t)) + ((input-drv-path input-drv) + (build-expression->derivation %store "input" + (%current-system) + builder '())) + ((input-path) + (derivation-output-path + (assoc-ref (derivation-outputs input-drv) + "out"))) + ((drv-path drv) + (build-expression->derivation %store "something" + (%current-system) + builder + `(("i" ,input-drv-path)))) + ((output) + (derivation-output-path + (assoc-ref (derivation-outputs drv) "out")))) + ;; Make sure these things are not already built. + (when (valid-path? %store input-path) + (delete-paths %store (list input-path))) + (when (valid-path? %store output) + (delete-paths %store (list output))) + + (and (equal? (map derivation-input-path + (derivation-prerequisites-to-build %store drv)) + (list input-drv-path)) + + ;; Build DRV and delete its input. + (build-derivations %store (list drv-path)) + (delete-paths %store (list input-path)) + (not (valid-path? %store input-path)) + + ;; Now INPUT-PATH is missing, yet it shouldn't be listed as a + ;; prerequisite to build because DRV itself is already built. + (null? (derivation-prerequisites-to-build %store drv))))) + (test-assert "build-expression->derivation with expression returning #f" (let* ((builder '(begin (mkdir %output) |