aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/derivations.scm52
-rw-r--r--tests/derivations.scm38
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)