03/06: DRAFT store: Add support for build continuations.

[Ludovic Courtès]

civodul pushed a commit to branch wip-gexp-grafts
in repository guix.

commit 6ec943d87c4230615f30eef4661e3dc73384bc1a
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jan 9 22:41:59 2017 +0100

    DRAFT store: Add support for build continuations.
    
    TODO: Add tests; update guix.texi.
    
    * guix/store.scm (<nix-server>)[continuations]: New field.
    (open-connection): Adjust accordingly.
    (set-build-continuation!, build-continuation): New procedures.
    (build-things): Rename to...
    (%build-things): ... this.
    (build-things, set-build-continuation): New procedures.
    * guix/derivations.scm (build-derivations): Add #:continuation?
    parameter and pass it to 'built-things'.  Convert the return value to a
    list of store items.
---
 guix/derivations.scm |   29 +++++++++++++++++++--------
 guix/store.scm       |   54 +++++++++++++++++++++++++++++++++++++++++++++++---
 2 files changed, 72 insertions(+), 11 deletions(-)

diff --git a/guix/derivations.scm b/guix/derivations.scm
index d5e4b57..c2a74b3 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -989,15 +989,28 @@ recursively."
 ;;;
 
 (define* (build-derivations store derivations
-                            #:optional (mode (build-mode normal)))
+                            #:optional (mode (build-mode normal))
+                            #:key (continuations? #t))
   "Build DERIVATIONS, a list of <derivation> objects or .drv file names, using
-the specified MODE."
-  (build-things store (map (match-lambda
-                            ((? string? file) file)
-                            ((and drv ($ <derivation>))
-                             (derivation-file-name drv)))
-                           derivations)
-                mode))
+the specified MODE.  When CONTINUATIONS? is true, run the \"build
+continuations\" of each of DERIVATIONS.  Return the list of store items that
+were built."
+  (let ((things (build-things store (map (match-lambda
+                                           ((? string? file) file)
+                                           ((and drv ($ <derivation>))
+                                            (derivation-file-name drv)))
+                                         derivations)
+                              mode)))
+    ;; Convert the list of .drv file names to a list of output file names.
+    (append-map (match-lambda
+                  ((? derivation-path? drv)
+                   (let ((drv (call-with-input-file drv read-derivation)))
+                     (match (derivation->output-paths drv)
+                       (((outputs . items) ...)
+                        items))))
+                  (x
+                   (list x)))
+                things)))
 
 
 ;;;
diff --git a/guix/store.scm b/guix/store.scm
index 49549d0..98478bc 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -71,6 +71,8 @@
             add-to-store
             build-things
             build
+            set-build-continuation!
+            set-build-continuation
             query-failed-paths
             clear-failed-paths
             add-temp-root
@@ -312,12 +314,16 @@
 
 (define-record-type <nix-server>
   (%make-nix-server socket major minor
-                    ats-cache atts-cache)
+                    continuations ats-cache atts-cache)
   nix-server?
   (socket nix-server-socket)
   (major  nix-server-major-version)
   (minor  nix-server-minor-version)
 
+  ;; Hash table that maps store items to a "build continuation" for that store
+  ;; item.
+  (continuations nix-server-build-continuations)
+
   ;; Caches.  We keep them per-connection, because store paths build
   ;; during the session are temporary GC roots kept for the duration of
   ;; the session.
@@ -400,6 +406,7 @@ for this connection will be pinned.  Return a server 
object."
                                                     (protocol-major v)
                                                     (protocol-minor v)
                                                     (make-hash-table 100)
+                                                    (make-hash-table 100)
                                                     (make-hash-table 100))))
                         (let loop ((done? (process-stderr conn)))
                           (or done? (process-stderr conn)))
@@ -720,7 +727,19 @@ where FILE is the entry's absolute file name and STAT is 
the result of
               (hash-set! cache args path)
               path))))))
 
-(define build-things
+(define (set-build-continuation! store item proc)
+  "Register PROC as a \"build continuation\" for when ITEM is built on STORE.
+When 'build-things' is passed ITEM, it calls (PROC STORE ITEM), which must
+return a list of store items to build."
+  (hash-set! (nix-server-build-continuations store) item proc))
+
+(define (build-continuation store item)
+  "Return the procedure that implements a \"build continuation\" for ITEM, or
+#f if there is none."
+  (hash-ref (nix-server-build-continuations store) item))
+
+(define %build-things
+  ;; This is the raw RPC.
   (let ((build (operation (build-things (string-list things)
                                         (integer mode))
                           "Do it!"
@@ -741,6 +760,29 @@ Return #t on success."
                                  (message "unsupported build mode")
                                  (status  1)))))))))
 
+(define* (build-things store things
+                       #:optional (mode (build-mode normal))
+                       #:key (continuations? #t))
+  "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.  When
+CONTINUATIONS? is true, run the \"build continuations\" of THINGS.  Return the
+list of store items built."
+  (let loop ((things things)
+             (built '()))
+    (match things
+      (()
+       built)
+      (_
+       (and (%build-things store things mode)
+            (loop (append-map (lambda (thing)
+                                (let ((proc (build-continuation store thing)))
+                                  (if proc
+                                      (proc store thing)
+                                      '())))
+                              things)
+                  things))))))
+
 (define-operation (add-temp-root (store-path path))
   "Make PATH a temporary root for the duration of the current session.
 Return #t."
@@ -1184,6 +1226,12 @@ where FILE is the entry's absolute file name and STAT is 
the result of
   ;; Monadic variant of 'build-things'.
   (store-lift build-things))
 
+(define (set-build-continuation item proc)
+  "Register monadic thunk PROC as a \"build continuation\" for ITEM."
+  (lambda (store)
+    (set-build-continuation! store item (store-lower proc))
+    (values *unspecified* store)))
+
 (define set-build-options*
   (store-lift set-build-options))