vm: Move store copy handling to (guix build store-copy).

* gnu/build/vm.scm (read-reference-graph, populate-store): Move to...
* guix/build/store-copy.scm: ... here.  New file.
* Makefile.am (MODULES): Add it.
* gnu/system/vm.scm (expression->derivation-in-linux-vm): Adjust default
  #:modules values accordingly.
* tests/gexp.scm ("gexp->derivation, store copy"): New test.

Makefile.am

@@ -64,6 +64,7 @@ MODULES =					\
   guix/build/gnu-dist.scm			\
   guix/build/perl-build-system.scm		\
   guix/build/python-build-system.scm		\
+  guix/build/store-copy.scm			\
   guix/build/utils.scm				\
   guix/build/union.scm				\
   guix/build/pull.scm				\

gnu/build/vm.scm

@@ -18,12 +18,11 @@
 
 (define-module (gnu build vm)
   #:use-module (guix build utils)
+  #:use-module (guix build store-copy)
   #:use-module (gnu build linux-boot)
   #:use-module (gnu build install)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
-  #:use-module (ice-9 rdelim)
-  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (qemu-command
             load-in-linux-vm
@@ -111,20 +110,6 @@ (define image-file
         (mkdir output)
         (copy-recursively "xchg" output))))
 
-(define (read-reference-graph port)
-  "Return a list of store paths from the reference graph at PORT.
-The data at PORT is the format produced by #:references-graphs."
-  (let loop ((line   (read-line port))
-             (result '()))
-    (cond ((eof-object? line)
-           (delete-duplicates result))
-          ((string-prefix? "/" line)
-           (loop (read-line port)
-                 (cons line result)))
-          (else
-           (loop (read-line port)
-                 result)))))
-
 (define* (initialize-partition-table device partition-size
                                      #:key
                                      (label-type "msdos")
@@ -140,26 +125,6 @@ (define* (initialize-partition-table device partition-size
                           (format #f "~aB" partition-size)))
     (error "failed to create partition table")))
 
-(define* (populate-store reference-graphs target)
-  "Populate the store under directory TARGET with the items specified in
-REFERENCE-GRAPHS, a list of reference-graph files."
-  (define store
-    (string-append target (%store-directory)))
-
-  (define (things-to-copy)
-    ;; Return the list of store files to copy to the image.
-    (define (graph-from-file file)
-      (call-with-input-file file read-reference-graph))
-
-    (delete-duplicates (append-map graph-from-file reference-graphs)))
-
-  (mkdir-p store)
-  (chmod store #o1775)
-  (for-each (lambda (thing)
-              (copy-recursively thing
-                                (string-append target thing)))
-            (things-to-copy)))
-
 (define MS_BIND 4096)                             ; <sys/mounts.h> again!
 
 (define* (format-partition partition type

gnu/system/vm.scm

@@ -116,7 +116,8 @@ (define* (expression->derivation-in-linux-vm name exp
                                                 (gnu build install)
                                                 (gnu build linux-boot)
                                                 (gnu build file-systems)
-                                                (guix build utils)))
+                                                (guix build utils)
+                                                (guix build store-copy)))
                                              (guile-for-build
                                               (%guile-for-build))
 

guix/build/store-copy.scm

@@ -0,0 +1,69 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build store-copy)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 rdelim)
+  #:export (read-reference-graph
+            populate-store))
+
+;;; Commentary:
+;;;
+;;; This module provides the tools to copy store items and their dependencies
+;;; to another store.  It relies on the availability of "reference graph"
+;;; files as produced by 'gexp->derivation' et al. with the
+;;; #:references-graphs parameter.
+;;;
+;;; Code:
+
+(define (read-reference-graph port)
+  "Return a list of store paths from the reference graph at PORT.
+The data at PORT is the format produced by #:references-graphs."
+  (let loop ((line   (read-line port))
+             (result '()))
+    (cond ((eof-object? line)
+           (delete-duplicates result))
+          ((string-prefix? "/" line)
+           (loop (read-line port)
+                 (cons line result)))
+          (else
+           (loop (read-line port)
+                 result)))))
+
+(define* (populate-store reference-graphs target)
+  "Populate the store under directory TARGET with the items specified in
+REFERENCE-GRAPHS, a list of reference-graph files."
+  (define store
+    (string-append target (%store-directory)))
+
+  (define (things-to-copy)
+    ;; Return the list of store files to copy to the image.
+    (define (graph-from-file file)
+      (call-with-input-file file read-reference-graph))
+
+    (delete-duplicates (append-map graph-from-file reference-graphs)))
+
+  (mkdir-p store)
+  (chmod store #o1775)
+  (for-each (lambda (thing)
+              (copy-recursively thing
+                                (string-append target thing)))
+            (things-to-copy)))
+
+;;; store-copy.scm ends here

tests/gexp.scm

@@ -324,6 +324,44 @@ (define (match-input thing)
     (return (string=? (derivation-file-name drv)
                       (derivation-file-name xdrv)))))
 
+(test-assertm "gexp->derivation, store copy"
+  (let ((build-one #~(call-with-output-file #$output
+                       (lambda (port)
+                         (display "This is the one." port))))
+        (build-two (lambda (one)
+                     #~(begin
+                         (mkdir #$output)
+                         (symlink #$one (string-append #$output "/one"))
+                         (call-with-output-file (string-append #$output "/two")
+                           (lambda (port)
+                             (display "This is the second one." port))))))
+        (build-drv (lambda (two)
+                     #~(begin
+                         (use-modules (guix build store-copy))
+
+                         (mkdir #$output)
+                         '#$two                   ;make it an input
+                         (populate-store '("graph") #$output)))))
+    (mlet* %store-monad ((one (gexp->derivation "one" build-one))
+                         (two (gexp->derivation "two" (build-two one)))
+                         (dir -> (derivation->output-path two))
+                         (drv (gexp->derivation "store-copy" (build-drv two)
+                                                #:references-graphs
+                                                `(("graph" . ,dir))
+                                                #:modules
+                                                '((guix build store-copy)
+                                                  (guix build utils))))
+                         (ok? (built-derivations (list drv)))
+                         (out -> (derivation->output-path drv)))
+      (let ((one (derivation->output-path one))
+            (two (derivation->output-path two)))
+        (return (and ok?
+                     (file-exists? (string-append out "/" one))
+                     (file-exists? (string-append out "/" two))
+                     (file-exists? (string-append out "/" two "/two"))
+                     (string=? (readlink (string-append out "/" two "/one"))
+                               one)))))))
+
 (define shebang
   (string-append "#!" (derivation->output-path (%guile-for-build))
                  "/bin/guile --no-auto-compile"))