From dd36b51bf7cffa389726ad997465b14f7072944a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 17 Apr 2013 00:06:59 +0200 Subject: scripts: Report what will be substituted. * guix/derivations.scm (derivation-input-output-paths): New procedure. (derivation-prerequisites-to-build): New `use-substitutes?' keyword argument. Change two return the list of substitutable paths as a second argument. * guix/ui.scm (show-what-to-build): Turn `dry-run?' into a keyword argument. New `use-substitutes?' keyword argument. Use `fold2' and adjust to use both return values of `derivation-prerequisites-to-build'. Display what will/would be downloaded. * guix/scripts/build.scm (guix-build): Adjust accordingly. * guix/scripts/package.scm (guix-package): Likewise. * tests/derivations.scm ("derivation-prerequisites-to-build and substitutes"): New test. --- guix/derivations.scm | 117 ++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 82 insertions(+), 35 deletions(-) (limited to 'guix/derivations.scm') diff --git a/guix/derivations.scm b/guix/derivations.scm index 2243d2ba46..cf329819c4 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -48,6 +48,7 @@ (define-module (guix derivations) derivation-input? derivation-input-path derivation-input-sub-derivations + derivation-input-output-paths fixed-output-derivation? derivation-hash @@ -99,6 +100,14 @@ (define (fixed-output-derivation? drv) #t) (_ #f))) +(define (derivation-input-output-paths input) + "Return the list of output paths corresponding to INPUT, a +." + (match input + (($ path sub-drvs) + (map (cut derivation-path->output-path path <>) + sub-drvs)))) + (define (derivation-prerequisites drv) "Return the list of derivation-inputs required to build DRV, recursively." (let loop ((drv drv) @@ -113,47 +122,85 @@ (define (derivation-prerequisites drv) inputs))))) (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." + #:key + (outputs + (map + car + (derivation-outputs drv))) + (use-substitutes? #t)) + "Return two values: the list of derivation-inputs required to build the +OUTPUTS of DRV and not already available in STORE, recursively, and the list +of required store paths that can be substituted. When USE-SUBSTITUTES? is #f, +that second value is the empty list." + (define (derivation-output-paths drv sub-drvs) + (match drv + (($ outputs) + (map (lambda (sub-drv) + (derivation-output-path (assoc-ref outputs sub-drv))) + sub-drvs)))) + (define built? (cut valid-path? store <>)) + (define substitutable? + ;; Return true if the given path is substitutable. Call + ;; `substitutable-paths' upfront, to benefit from parallelism in the + ;; substituter. + (if use-substitutes? + (let ((s (substitutable-paths store + (append + (derivation-output-paths drv outputs) + (append-map + derivation-input-output-paths + (derivation-prerequisites drv)))))) + (cut member <> s)) + (const #f))) + (define input-built? - (match-lambda - (($ path sub-drvs) - (let ((out (map (cut derivation-path->output-path path <>) - sub-drvs))) - (any built? out))))) + (compose (cut any built? <>) derivation-input-output-paths)) + + (define input-substitutable? + ;; Return true if and only if all of SUB-DRVS are subsitutable. If at + ;; least one is missing, then everything must be rebuilt. + (compose (cut every substitutable? <>) derivation-input-output-paths)) (define (derivation-built? drv sub-drvs) - (match drv - (($ 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)))))) + (every built? (derivation-output-paths drv sub-drvs))) + + (define (derivation-substitutable? drv sub-drvs) + (every substitutable? (derivation-output-paths drv sub-drvs))) + + (let loop ((drv drv) + (sub-drvs outputs) + (build '()) + (substitute '())) + (cond ((derivation-built? drv sub-drvs) + (values build substitute)) + ((derivation-substitutable? drv sub-drvs) + (values build + (append (derivation-output-paths drv sub-drvs) + substitute))) + (else + (let ((inputs (remove (lambda (i) + (or (member i build) ; XXX: quadratic + (input-built? i) + (input-substitutable? i))) + (derivation-inputs drv)))) + (fold2 loop + (append inputs build) + (append (append-map (lambda (input) + (if (and (not (input-built? input)) + (input-substitutable? input)) + (derivation-input-output-paths + input) + '())) + (derivation-inputs drv)) + substitute) + (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) ;; Actually read derivation from DRV-PORT. -- cgit v1.2.3