Merge branch 'master' into core-updates

1 files changed, 94 insertions, 83 deletions

diff --git a/guix/build/vm.scm b/guix/build/vm.scm
index 33c898d968..e559542f0a 100644
--- a/guix/build/vm.scm
+++ b/guix/build/vm.scm
@@ -19,11 +19,15 @@
 (define-module (guix build vm)
   #:use-module (guix build utils)
   #:use-module (guix build linux-initrd)
+  #:use-module (guix build install)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (load-in-linux-vm
+            format-partition
+            initialize-root-partition
+            initialize-partition-table
             initialize-hard-disk))
 
 ;;; Commentary:
@@ -46,6 +50,7 @@
                            (qemu (qemu-command)) (memory-size 512)
                            linux initrd
                            make-disk-image? (disk-image-size 100)
+                           (disk-image-format "qcow2")
                            (references-graphs '()))
   "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
 the result to OUTPUT.
@@ -56,9 +61,12 @@ it via /dev/hda.
 
 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
 the #:references-graphs parameter of 'derivation'."
+  (define image-file
+    (string-append "image." disk-image-format))
 
   (when make-disk-image?
-    (unless (zero? (system* "qemu-img" "create" "-f" "qcow2" "image.qcow2"
+    (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
+                            image-file
                             (number->string disk-image-size)))
       (error "qemu-img failed")))
 
@@ -88,13 +96,13 @@ the #:references-graphs parameter of 'derivation'."
                   "-append" (string-append "console=ttyS0 --load="
                                            builder)
                   (if make-disk-image?
-                      '("-hda" "image.qcow2")
+                      `("-drive" ,(string-append "file=" image-file
+                                                 ",if=virtio"))
                       '())))
     (error "qemu failed" qemu))
 
   (if make-disk-image?
-      (copy-file "image.qcow2"            ; XXX: who mkdir'd OUTPUT?
-                 output)
+      (copy-file image-file output)
       (begin
         (mkdir output)
         (copy-recursively "xchg" output))))
@@ -113,25 +121,20 @@ The data at PORT is the format produced by #:references-graphs."
            (loop (read-line port)
                  result)))))
 
-(define* (initialize-partition-table device
+(define* (initialize-partition-table device partition-size
                                      #:key
                                      (label-type "msdos")
-                                     partition-size)
+                                     (offset (expt 2 20)))
   "Create on DEVICE a partition table of type LABEL-TYPE, with a single
-partition of PARTITION-SIZE MiB.  Return #t on success."
-  (display "creating partition table...\n")
-  (zero? (system* "parted" "/dev/sda" "mklabel" label-type
-                  "mkpart" "primary" "ext2" "1MiB"
-                  (format #f "~aB" partition-size))))
-
-(define* (install-grub grub.cfg device mount-point)
-  "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
-MOUNT-POINT.  Return #t on success."
-  (mkdir-p (string-append mount-point "/boot/grub"))
-  (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg"))
-  (zero? (system* "grub-install" "--no-floppy"
-                  "--boot-directory" (string-append mount-point "/boot")
-                  device)))
+partition of PARTITION-SIZE bytes starting at OFFSET bytes.  Return #t on
+success."
+  (format #t "creating partition table with a ~a B partition...\n"
+          partition-size)
+  (unless (zero? (system* "parted" device "mklabel" label-type
+                          "mkpart" "primary" "ext2"
+                          (format #f "~aB" offset)
+                          (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
@@ -153,80 +156,88 @@ REFERENCE-GRAPHS, a list of reference-graph files."
                                 (string-append target thing)))
             (things-to-copy)))
 
-(define (evaluate-populate-directive directive target)
-  "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
-directory TARGET."
-  (match directive
-    (('directory name)
-     (mkdir-p (string-append target name)))
-    (('directory name uid gid)
-     (let ((dir (string-append target name)))
-       (mkdir-p dir)
-       (chown dir uid gid)))
-    ((new '-> old)
-     (symlink old (string-append target new)))))
-
-(define (reset-timestamps directory)
-  "Reset the timestamps of all the files under DIRECTORY, so that they appear
-as created and modified at the Epoch."
-  (display "clearing file timestamps...\n")
-  (for-each (lambda (file)
-              (let ((s (lstat file)))
-                ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so
-                ;; the timestamp of symlinks cannot be changed, and there are
-                ;; symlinks here pointing to /gnu/store, which is the host,
-                ;; read-only store.
-                (unless (eq? (stat:type s) 'symlink)
-                  (utime file 0 0 0 0))))
-            (find-files directory "")))
-
-(define* (initialize-hard-disk #:key
-                               grub.cfg
-                               disk-image-size
-                               (mkfs "mkfs.ext3")
-                               initialize-store?
-                               (closures-to-copy '())
-                               (directives '()))
-  (unless (initialize-partition-table "/dev/sda"
-                                      #:partition-size
-                                      (- disk-image-size (* 5 (expt 2 20))))
-    (error "failed to create partition table"))
-
-  (display "creating ext3 partition...\n")
-  (unless (zero? (system* mkfs "-F" "/dev/sda1"))
-    (error "failed to create partition"))
+(define MS_BIND 4096)                             ; <sys/mounts.h> again!
 
-  (display "mounting partition...\n")
-  (mkdir "/fs")
-  (mount "/dev/sda1" "/fs" "ext3")
+(define (format-partition partition type)
+  "Create a file system TYPE on PARTITION."
+  (format #t "creating ~a partition...\n" type)
+  (unless (zero? (system* (string-append "mkfs." type) "-F" partition))
+    (error "failed to create partition")))
 
-  (when (pair? closures-to-copy)
+(define* (initialize-root-partition target-directory
+                                    #:key copy-closures? register-closures?
+                                    closures)
+  "Initialize the root partition mounted at TARGET-DIRECTORY."
+  (define target-store
+    (string-append target-directory (%store-directory)))
+
+  (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)))
+
+  ;; Add the non-store directories and files.
+  (display "populating...\n")
+  (populate-root-file-system target-directory))
+
+(define* (initialize-hard-disk device
+                               #:key
+                               grub.cfg
+                               disk-image-size
+                               (file-system-type "ext4")
+                               (closures '())
+                               copy-closures?
+                               (register-closures? #t))
+  "Initialize DEVICE, 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."
+  (define target-directory
+    "/fs")
+
+  (define partition
+    (string-append device "1"))
+
+  (initialize-partition-table device
+                              (- disk-image-size (* 5 (expt 2 20))))
+
+  (format-partition partition file-system-type)
+
+  (display "mounting partition...\n")
+  (mkdir target-directory)
+  (mount partition target-directory file-system-type)
 
-  ;; Evaluate the POPULATE directives.
-  (for-each (cut evaluate-populate-directive <> "/fs")
-            directives)
+  (initialize-root-partition target-directory
+                             #:copy-closures? copy-closures?
+                             #:register-closures? register-closures?
+                             #:closures closures)
 
-  (unless (install-grub grub.cfg "/dev/sda" "/fs")
-    (error "failed to install GRUB"))
+  (install-grub grub.cfg device target-directory)
 
-  (reset-timestamps "/fs")
+  ;; 'guix-register' resets timestamps and everything, so no need to do it
+  ;; once more in that case.
+  (unless register-closures?
+    (reset-timestamps target-directory))
 
-  (zero? (system* "umount" "/fs")))
+  (zero? (system* "umount" target-directory)))
 
 ;;; vm.scm ends here