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.

2 files changed, 74 insertions, 16 deletions

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 7b131955b0..ce8858a2fa 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -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
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 061a9bd42b..119edfcb86 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -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)