TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
guix/derivations.scm
View File

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

38
tests/derivations.scm
View File

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