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:
Ludovic Courtès 2013-01-09 08:38:57 +01:00
parent 98fefb210a
commit 784bb1f37b
2 changed files with 74 additions and 16 deletions

View File

@ -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

View File

@ -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)