diff options
| -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) |