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.
This commit is contained in:
parent
98fefb210a
commit
784bb1f37b
|
@ -112,18 +112,37 @@ download with a fixed hash (aka. `fetchurl')."
|
||||||
read-derivation))
|
read-derivation))
|
||||||
inputs)))))
|
inputs)))))
|
||||||
|
|
||||||
(define (derivation-prerequisites-to-build store drv)
|
(define* (derivation-prerequisites-to-build store drv
|
||||||
"Return the list of derivation-inputs required to build DRV and not already
|
#:key (outputs
|
||||||
available in STORE, recursively."
|
(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?
|
(define input-built?
|
||||||
(match-lambda
|
(match-lambda
|
||||||
(($ <derivation-input> path sub-drvs)
|
(($ <derivation-input> path sub-drvs)
|
||||||
(let ((out (map (cut derivation-path->output-path path <>)
|
(let ((out (map (cut derivation-path->output-path path <>)
|
||||||
sub-drvs)))
|
sub-drvs)))
|
||||||
(any (cut valid-path? store <>) out)))))
|
(any built? out)))))
|
||||||
|
|
||||||
|
(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)
|
(let loop ((drv drv)
|
||||||
|
(sub-drvs outputs)
|
||||||
(result '()))
|
(result '()))
|
||||||
|
(if (derivation-built? drv sub-drvs)
|
||||||
|
result
|
||||||
(let ((inputs (remove (lambda (i)
|
(let ((inputs (remove (lambda (i)
|
||||||
(or (member i result) ; XXX: quadratic
|
(or (member i result) ; XXX: quadratic
|
||||||
(input-built? i)))
|
(input-built? i)))
|
||||||
|
@ -133,7 +152,8 @@ available in STORE, recursively."
|
||||||
(map (lambda (i)
|
(map (lambda (i)
|
||||||
(call-with-input-file (derivation-input-path i)
|
(call-with-input-file (derivation-input-path i)
|
||||||
read-derivation))
|
read-derivation))
|
||||||
inputs)))))
|
inputs)
|
||||||
|
(map derivation-input-sub-derivations inputs))))))
|
||||||
|
|
||||||
(define (read-derivation drv-port)
|
(define (read-derivation drv-port)
|
||||||
"Read the derivation from DRV-PORT and return the corresponding
|
"Read the derivation from DRV-PORT and return the corresponding
|
||||||
|
|
|
@ -353,6 +353,44 @@
|
||||||
;; built.
|
;; built.
|
||||||
(null? (derivation-prerequisites-to-build %store drv))))
|
(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"
|
(test-assert "build-expression->derivation with expression returning #f"
|
||||||
(let* ((builder '(begin
|
(let* ((builder '(begin
|
||||||
(mkdir %output)
|
(mkdir %output)
|
||||||
|
|
Loading…
Reference in New Issue