03/06: store: 'build-things' accepts derivation/output pairs.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit f8a9f99cd602ce1dc5307cb0c21ae718ad8796bb
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jun 10 22:10:21 2019 +0200

    store: 'build-things' accepts derivation/output pairs.
    
    This allows callers to request the substitution of a single derivation
    output.
    
    * guix/store.scm (build-things): Accept derivation/output pairs among
    THINGS.
    * guix/derivations.scm (build-derivations): Likewise.
    * tests/store.scm ("substitute + build-things with specific output"):
    New test.
    * tests/derivations.scm ("build-derivations with specific output"):
    New test.
    * doc/guix.texi (The Store): Adjust accordingly.
---
 doc/guix.texi         |  9 +++++----
 guix/derivations.scm  | 13 +++++++++----
 guix/store.scm        | 26 ++++++++++++++++----------
 tests/derivations.scm | 22 ++++++++++++++++++++++
 tests/store.scm       | 20 ++++++++++++++++++++
 5 files changed, 72 insertions(+), 18 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 93bec28..87dc6ea 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6466,10 +6466,11 @@ path.  @var{references} is the list of store paths 
referred to by the
 resulting store path.
 @end deffn
 
-@deffn {Scheme Procedure} build-derivations @var{server} @var{derivations}
-Build @var{derivations} (a list of @code{<derivation>} objects or
-derivation paths), and return when the worker is done building them.
-Return @code{#t} on success.
+@deffn {Scheme Procedure} build-derivations @var{store} @var{derivations} @
+  [@var{mode}]
+Build @var{derivations}, a list of @code{<derivation>} objects, @file{.drv}
+file names, or derivation/output pairs, using the specified
+@var{mode}---@code{(build-mode normal)} by default.
 @end deffn
 
 Note that the @code{(guix monads)} module provides a monad as well as
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 7a5c3bc..cad77bd 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -982,12 +982,17 @@ recursively."
 
 (define* (build-derivations store derivations
                             #:optional (mode (build-mode normal)))
-  "Build DERIVATIONS, a list of <derivation> objects or .drv file names, using
-the specified MODE."
+  "Build DERIVATIONS, a list of <derivation> objects, .drv file names, or
+derivation/output pairs, using the specified MODE."
   (build-things store (map (match-lambda
+                            ((? derivation? drv)
+                             (derivation-file-name drv))
                             ((? string? file) file)
-                            ((and drv ($ <derivation>))
-                             (derivation-file-name drv)))
+                            (((? derivation? drv) . output)
+                             (cons (derivation-file-name drv)
+                                   output))
+                            (((? string? file) . output)
+                             (cons file output)))
                            derivations)
                 mode))
 
diff --git a/guix/store.scm b/guix/store.scm
index 738c0fb..8fa1649 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1211,16 +1211,22 @@ an arbitrary directory layout in the store without 
creating a derivation."
       "Build THINGS, a list of store items which may be either '.drv' files or
 outputs, and return when the worker is done building them.  Elements of THINGS
 that are not derivations can only be substituted and not built locally.
-Return #t on success."
-      (parameterize ((current-store-protocol-version
-                      (store-connection-version store)))
-        (if (>= (store-connection-minor-version store) 15)
-            (build store things mode)
-            (if (= mode (build-mode normal))
-                (build/old store things)
-                (raise (condition (&store-protocol-error
-                                   (message "unsupported build mode")
-                                   (status  1))))))))))
+Alternately, an element of THING can be a derivation/output name pair, in
+which case the daemon will attempt to substitute just the requested output of
+the derivation.  Return #t on success."
+      (let ((things (map (match-lambda
+                           ((drv . output) (string-append drv "!" output))
+                           (thing thing))
+                         things)))
+        (parameterize ((current-store-protocol-version
+                        (store-connection-version store)))
+          (if (>= (store-connection-minor-version store) 15)
+              (build store things mode)
+              (if (= mode (build-mode normal))
+                  (build/old store things)
+                  (raise (condition (&store-protocol-error
+                                     (message "unsupported build mode")
+                                     (status  1)))))))))))
 
 (define-operation (add-temp-root (store-path path))
   "Make PATH a temporary root for the duration of the current session.
diff --git a/tests/derivations.scm b/tests/derivations.scm
index dbb5b58..c421d09 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -787,6 +787,28 @@
       (build-derivations store (list drv))
       #f)))
 
+(test-assert "build-derivations with specific output"
+  (with-store store
+    (let* ((content (random-text))                ;contents of the output
+           (drv     (build-expression->derivation
+                     store "substitute-me"
+                     `(begin ,content (exit 1))   ;would fail
+                     #:outputs '("out" "one" "two")
+                     #:guile-for-build
+                     (package-derivation store %bootstrap-guile)))
+           (out     (derivation->output-path drv)))
+      (with-derivation-substitute drv content
+        (set-build-options store #:use-substitutes? #t
+                           #:substitute-urls (%test-substitute-urls))
+        (and (has-substitutes? store out)
+
+             ;; Ask for nothing but the "out" output of DRV.
+             (build-derivations store `((,drv . "out")))
+
+             (valid-path? store out)
+             (equal? (pk 'x content) (pk 'y (call-with-input-file out 
get-string-all)))
+             )))))
+
 (test-assert "build-expression->derivation and 
derivation-prerequisites-to-build"
   (let ((drv (build-expression->derivation %store "fail" #f)))
     ;; The only direct dependency is (%guile-for-build) and it's already
diff --git a/tests/store.scm b/tests/store.scm
index df66fea..518750d 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -599,6 +599,26 @@
              (valid-path? s o)
              (equal? c (call-with-input-file o get-string-all)))))))
 
+(test-assert "substitute + build-things with specific output"
+  (with-store s
+    (let* ((c   (random-text))                    ;contents of the output
+           (d   (build-expression->derivation
+                 s "substitute-me" `(begin ,c (exit 1)) ;would fail
+                 #:outputs '("out" "one" "two")
+                 #:guile-for-build
+                 (package-derivation s %bootstrap-guile (%current-system))))
+           (o   (derivation->output-path d)))
+      (with-derivation-substitute d c
+        (set-build-options s #:use-substitutes? #t
+                           #:substitute-urls (%test-substitute-urls))
+        (and (has-substitutes? s o)
+
+             ;; Ask for nothing but the "out" output of D.
+             (build-things s `((,(derivation-file-name d) . "out")))
+
+             (valid-path? s o)
+             (equal? c (call-with-input-file o get-string-all)))))))
+
 (test-assert "substitute, corrupt output hash"
   ;; Tweak the substituter into installing a substitute whose hash doesn't
   ;; match the one announced in the narinfo.  The daemon must notice this and