vm: Support initialization of the store DB when the store is shared.

* gnu/system/vm.scm (qemu-image): Rename #:inputs-to-copy to #:inputs,
  and #:initialize-store? to #:register-closures?.  Add #:copy-inputs?.
  Adjust build gexp accordingly.
  (system-qemu-image): Remove #:initialize-store? argument and add
  #:copy-inputs?.
  (system-qemu-image/shared-store): Add #:inputs, #:register-closures?,
  and #:copy-inputs? arguments.
* guix/build/vm.scm (register-closure): New procedure.
  (MS_BIND): New variable.
  (initialize-hard-disk): Rename #:initialize-store? to
  #:register-closures?, #:closures-to-copy to #:closures, and add
  #:copy-closures?.
  Add 'target-directory' and 'target-store' variables.
  Call 'populate-store' only when COPY-CLOSURES?.
  Bind-mount the store to TARGET-STORE when REGISTER-CLOSURES? and not
  COPY-CLOSURES?.  Add call to 'register-closure'.

2 files changed, 72 insertions, 36 deletions

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index f42feb394c..7008c5dab2 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -192,25 +192,26 @@ made available under the /xchg CIFS share."
                      (disk-image-size (* 100 (expt 2 20)))
                      (file-system-type "ext4")
                      grub-configuration
-                     (initialize-store? #f)
+                     (register-closures? #t)
                      (populate #f)
-                     (inputs-to-copy '()))
+                     (inputs '())
+                     copy-inputs?)
   "Return a bootable, stand-alone QEMU image, with a root partition of type
 FILE-SYSTEM-TYPE.  The returned image is a full disk image, with a GRUB
 installation that uses GRUB-CONFIGURATION as its configuration
 file (GRUB-CONFIGURATION must be the name of a file in the VM.)
 
-INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
-into the image being built.  When INITIALIZE-STORE? is true, initialize the
-store database in the image so that Guix can be used in the image.
+INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
+all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
+register INPUTS in the store database of the image so that Guix can be used in
+the image.
 
 POPULATE is a list of directives stating directories or symlinks to be created
 in the disk image partition.  It is evaluated once the image has been
 populated with INPUTS-TO-COPY.  It can be used to provide additional files,
 such as /etc files."
   (mlet %store-monad
-      ((graph (sequence %store-monad
-                        (map input->name+output inputs-to-copy))))
+      ((graph (sequence %store-monad (map input->name+output inputs))))
    (expression->derivation-in-linux-vm
     name
     #~(begin
@@ -221,26 +222,27 @@ such as /etc files."
                '#$(append (list qemu parted grub e2fsprogs util-linux)
                           (map (compose car (cut assoc-ref %final-inputs <>))
                                '("sed" "grep" "coreutils" "findutils" "gawk"))
-                          (if initialize-store? (list guix) '())))
+                          (if register-closures? (list guix) '())))
 
               ;; This variable is unused but allows us to add INPUTS-TO-COPY
               ;; as inputs.
-              (to-copy
+              (to-register
                 '#$(map (match-lambda
                          ((name thing) thing)
                          ((name thing output) `(,thing ,output)))
-                        inputs-to-copy)))
+                        inputs)))
 
           (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 
-          (let ((graphs '#$(match inputs-to-copy
+          (let ((graphs '#$(match inputs
                              (((names . _) ...)
                               names))))
             (initialize-hard-disk #:grub.cfg #$grub-configuration
-                                  #:closures-to-copy graphs
+                                  #:closures graphs
+                                  #:copy-closures? #$copy-inputs?
+                                  #:register-closures? #$register-closures?
                                   #:disk-image-size #$disk-image-size
                                   #:file-system-type #$file-system-type
-                                  #:initialize-store? #$initialize-store?
                                   #:directives '#$populate)
             (reboot))))
     #:system system
@@ -318,8 +320,8 @@ of the GNU system as described by OS."
                    #:populate populate
                    #:disk-image-size disk-image-size
                    #:file-system-type file-system-type
-                   #:initialize-store? #t
-                   #:inputs-to-copy `(("system" ,os-drv))))))
+                   #:inputs `(("system" ,os-drv))
+                   #:copy-inputs? #t))))
 
 (define (virtualized-operating-system os)
   "Return an operating system based on OS suitable for use in a virtualized
@@ -358,10 +360,14 @@ with the host."
        (os-dir   -> (derivation->output-path os-drv))
        (grub.cfg -> (string-append os-dir "/grub.cfg"))
        (populate    (operating-system-default-contents os)))
-    ;; TODO: Initialize the database so Guix can be used in the guest.
     (qemu-image #:grub-configuration grub.cfg
                 #:populate populate
-                #:disk-image-size disk-image-size)))
+                #:disk-image-size disk-image-size
+                #:inputs `(("system" ,os-drv))
+
+                ;; XXX: Passing #t here is too slow, so let it off by default.
+                #:register-closures? #f
+                #:copy-inputs? #f)))
 
 (define* (system-qemu-image/shared-store-script
           os
diff --git a/guix/build/vm.scm b/guix/build/vm.scm
index 1d1abad1dd..2c13a8904b 100644
--- a/guix/build/vm.scm
+++ b/guix/build/vm.scm
@@ -180,13 +180,36 @@ as created and modified at the Epoch."
                   (utime file 0 0 0 0))))
             (find-files directory "")))
 
+(define (register-closure store closure)
+  "Register CLOSURE in STORE, where STORE is the directory name of the target
+store and CLOSURE is the name of a file containing a reference graph as used
+by 'guix-register'."
+  (let ((status (system* "guix-register" "--prefix" store
+                         closure)))
+    (unless (zero? status)
+      (error "failed to register store items" closure))))
+
+(define MS_BIND 4096)                             ; <sys/mounts.h> again!
+
 (define* (initialize-hard-disk #:key
                                grub.cfg
                                disk-image-size
                                (file-system-type "ext4")
-                               initialize-store?
-                               (closures-to-copy '())
+                               (closures '())
+                               copy-closures?
+                               (register-closures? #t)
                                (directives '()))
+  "Initialize /dev/sda, a disk of DISK-IMAGE-SIZE bytes, with a
+FILE-SYSTEM-TYPE partition, and with GRUB installed.  If REGISTER-CLOSURES? is
+true, register all of CLOSURES is the partition's store.  If COPY-CLOSURES? is
+true, copy all of CLOSURES to the partition.  Lastly, apply DIRECTIVES to
+further populate the partition."
+  (define target-directory
+    "/fs")
+
+  (define target-store
+    (string-append target-directory (%store-directory)))
+
   (unless (initialize-partition-table "/dev/sda"
                                       #:partition-size
                                       (- disk-image-size (* 5 (expt 2 20))))
@@ -198,36 +221,43 @@ as created and modified at the Epoch."
     (error "failed to create partition"))
 
   (display "mounting partition...\n")
-  (mkdir "/fs")
-  (mount "/dev/sda1" "/fs" file-system-type)
+  (mkdir target-directory)
+  (mount "/dev/sda1" target-directory file-system-type)
 
-  (when (pair? closures-to-copy)
+  (when copy-closures?
     ;; Populate the store.
-    (populate-store (map (cut string-append "/xchg/" <>)
-                         closures-to-copy)
-                    "/fs"))
+    (populate-store (map (cut string-append "/xchg/" <>) closures)
+                    target-directory))
 
   ;; Populate /dev.
-  (make-essential-device-nodes #:root "/fs")
+  (make-essential-device-nodes #:root target-directory)
 
   ;; Optionally, register the inputs in the image's store.
-  (when initialize-store?
+  (when register-closures?
+    (unless copy-closures?
+      ;; XXX: 'guix-register' wants to palpate the things it registers, so
+      ;; bind-mount the store on the target.
+      (mkdir-p target-store)
+      (mount (%store-directory) target-store "" MS_BIND))
+
+    (display "registering closures...\n")
     (for-each (lambda (closure)
-                (let ((status (system* "guix-register" "--prefix" "/fs"
-                                       (string-append "/xchg/" closure))))
-                  (unless (zero? status)
-                    (error "failed to register store items" closure))))
-              closures-to-copy))
+                (register-closure target-directory
+                                  (string-append "/xchg/" closure)))
+              closures)
+    (unless copy-closures?
+      (system* "umount" target-store)))
 
   ;; Evaluate the POPULATE directives.
-  (for-each (cut evaluate-populate-directive <> "/fs")
+  (display "populating...\n")
+  (for-each (cut evaluate-populate-directive <> target-directory)
             directives)
 
-  (unless (install-grub grub.cfg "/dev/sda" "/fs")
+  (unless (install-grub grub.cfg "/dev/sda" target-directory)
     (error "failed to install GRUB"))
 
-  (reset-timestamps "/fs")
+  (reset-timestamps target-directory)
 
-  (zero? (system* "umount" "/fs")))
+  (zero? (system* "umount" target-directory)))
 
 ;;; vm.scm ends here