Add derivation-prerequisites' and derivation-prerequisites-to-build'.

* guix/derivations.scm (derivation-prerequisites,
  derivation-prerequisites-to-build): New procedures.

* tests/derivations.scm ("build-expression->derivation and
  derivation-prerequisites", "build-expression->derivation and
  derivation-prerequisites-to-build"): New tests.
This commit is contained in:
Ludovic Courtès 2012-07-01 00:37:03 +02:00
parent 31ef99a8a5
commit 9a20830e57
2 changed files with 60 additions and 2 deletions

View file

@ -26,19 +26,24 @@ (define-module (guix derivations)
#:use-module (ice-9 rdelim) #:use-module (ice-9 rdelim)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)
#:export (derivation? #:export (<derivation>
derivation?
derivation-outputs derivation-outputs
derivation-inputs derivation-inputs
derivation-sources derivation-sources
derivation-system derivation-system
derivation-builder-arguments derivation-builder-arguments
derivation-builder-environment-vars derivation-builder-environment-vars
derivation-prerequisites
derivation-prerequisites-to-build
<derivation-output>
derivation-output? derivation-output?
derivation-output-path derivation-output-path
derivation-output-hash-algo derivation-output-hash-algo
derivation-output-hash derivation-output-hash
<derivation-input>
derivation-input? derivation-input?
derivation-input-path derivation-input-path
derivation-input-sub-derivations derivation-input-sub-derivations
@ -92,6 +97,42 @@ (define (fixed-output-derivation? drv)
#t) #t)
(_ #f))) (_ #f)))
(define (derivation-prerequisites drv)
"Return the list of derivation-inputs required to build DRV, recursively."
(let loop ((drv drv)
(result '()))
(let ((inputs (remove (cut member <> result) ; XXX: quadratic
(derivation-inputs drv))))
(fold loop
(append inputs result)
(map (lambda (i)
(call-with-input-file (derivation-input-path i)
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 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)))))
(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 (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
<derivation> object." <derivation> object."

View file

@ -172,7 +172,16 @@ (define %coreutils
(and (valid-path? %store p) (and (valid-path? %store p)
(file-exists? (string-append p "/good"))))))) (file-exists? (string-append p "/good")))))))
(test-skip (if (%guile-for-build) 0 4)) (test-skip (if (%guile-for-build) 0 6))
(test-assert "build-expression->derivation and derivation-prerequisites"
(let-values (((drv-path drv)
(build-expression->derivation %store "fail" (%current-system)
#f '())))
(any (match-lambda
(($ <derivation-input> path)
(string=? path (%guile-for-build))))
(derivation-prerequisites drv))))
(test-assert "build-expression->derivation without inputs" (test-assert "build-expression->derivation without inputs"
(let* ((builder '(begin (let* ((builder '(begin
@ -188,6 +197,14 @@ (define %coreutils
(equal? '(hello guix) (equal? '(hello guix)
(call-with-input-file (string-append p "/test") read)))))) (call-with-input-file (string-append p "/test") read))))))
(test-assert "build-expression->derivation and derivation-prerequisites-to-build"
(let-values (((drv-path drv)
(build-expression->derivation %store "fail" (%current-system)
#f '())))
;; The only direct dependency is (%guile-for-build) and it's 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)