vm: Move image creation to (guix build vm); split into several procedures.

* guix/build/vm.scm (read-reference-graph, initialize-partition-table,
  install-grub, populate-store, evaluate-populate-directive,
  reset-timestamps, initialize-hard-disk): New procedures.
* gnu/system/vm.scm (qemu-image): Change 'builder' to a call to
  'initialize-hard-disk'.

2 files changed, 152 insertions, 150 deletions

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index b0fd3f5710..069ac3093a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -217,154 +217,21 @@ such as /etc files."
    (expression->derivation-in-linux-vm
     "qemu-image"
     `(let ()
-       (use-modules (ice-9 rdelim)
-                    (srfi srfi-1)
-                    (guix build utils)
-                    (guix build linux-initrd))
-
-       (let ((parted  (string-append (assoc-ref %build-inputs "parted")
-                                     "/sbin/parted"))
-             (mkfs    (string-append (assoc-ref %build-inputs "e2fsprogs")
-                                     "/sbin/mkfs.ext3"))
-             (grub    (string-append (assoc-ref %build-inputs "grub")
-                                     "/sbin/grub-install"))
-             (umount  (string-append (assoc-ref %build-inputs "util-linux")
-                                     "/bin/umount")) ; XXX: add to Guile
-             (grub.cfg ,grub-configuration))
-
-         (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 (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))
-
-           ,(match inputs-to-copy
-              (((graph-files . _) ...)
-               `(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
-                                           graph-files))
-                       (paths       (append-map graph-from-file graph-files)))
-                  (delete-duplicates paths)))
-              (#f ''())))
-
-         ;; GRUB is full of shell scripts.
-         (setenv "PATH"
-                 (string-append (dirname grub) ":"
-                                (assoc-ref %build-inputs "coreutils") "/bin:"
-                                (assoc-ref %build-inputs "findutils") "/bin:"
-                                (assoc-ref %build-inputs "sed") "/bin:"
-                                (assoc-ref %build-inputs "grep") "/bin:"
-                                (assoc-ref %build-inputs "gawk") "/bin"))
-
-         (display "creating partition table...\n")
-         (and (zero? (system* parted "/dev/sda" "mklabel" "msdos"
-                              "mkpart" "primary" "ext2" "1MiB"
-                              ,(format #f "~aB"
-                                       (- disk-image-size
-                                          (* 5 (expt 2 20))))))
-              (begin
-                (display "creating ext3 partition...\n")
-                (and (zero? (system* mkfs "-F" "/dev/sda1"))
-                     (let ((store (string-append "/fs" ,(%store-prefix))))
-                       (display "mounting partition...\n")
-                       (mkdir "/fs")
-                       (mount "/dev/sda1" "/fs" "ext3")
-                       (mkdir-p "/fs/boot/grub")
-                       (symlink grub.cfg "/fs/boot/grub/grub.cfg")
-
-                       ;; Populate the image's store.
-                       (mkdir-p store)
-                       (chmod store #o1775)
-                       (for-each (lambda (thing)
-                                   (copy-recursively thing
-                                                     (string-append "/fs"
-                                                                    thing)))
-                                 (things-to-copy))
-
-                       ;; Populate /dev.
-                       (make-essential-device-nodes #:root "/fs")
-
-                       ;; Optionally, register the inputs in the image's store.
-                       (let* ((guix     (assoc-ref %build-inputs "guix"))
-                              (register (and guix
-                                             (string-append guix
-                                                            "/sbin/guix-register"))))
-                         ,@(if initialize-store?
-                               (match inputs-to-copy
-                                 (((graph-files . _) ...)
-                                  (map (lambda (closure)
-                                         `(system* register "--prefix" "/fs"
-                                                   ,(string-append "/xchg/"
-                                                                   closure)))
-                                       graph-files)))
-                               '(#f)))
-
-                       ;; Evaluate the POPULATE directives.
-                       ,@(let loop ((directives populate)
-                                    (statements '()))
-                           (match directives
-                             (()
-                              (reverse statements))
-                             ((('directory name) rest ...)
-                              (loop rest
-                                    (cons `(mkdir-p ,(string-append "/fs" name))
-                                          statements)))
-                             ((('directory name uid gid) rest ...)
-                              (let ((dir (string-append "/fs" name)))
-                                (loop rest
-                                      (cons* `(chown ,dir ,uid ,gid)
-                                             `(mkdir-p ,dir)
-                                             statements))))
-                             (((new '-> old) rest ...)
-                              (loop rest
-                                    (cons `(symlink ,old
-                                                    ,(string-append "/fs" new))
-                                          statements)))))
-
-                       (and=> (assoc-ref %build-inputs "populate")
-                              (lambda (populate)
-                                (chdir "/fs")
-                                (primitive-load populate)
-                                (chdir "/")))
-
-                       (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 "/fs" ".*"))
-
-                       (and (zero?
-                             (system* grub "--no-floppy"
-                                      "--boot-directory" "/fs/boot"
-                                      "/dev/sda"))
-                            (begin
-                              (when (file-exists? "/fs/dev/pts")
-                                ;; Unmount devpts so /fs itself can be
-                                ;; unmounted (failing to do that leads to
-                                ;; EBUSY.)
-                                (system* umount "/fs/dev/pts"))
-                              (zero? (system* umount "/fs")))
-                            (reboot))))))))
+       (use-modules (guix build vm)
+                    (guix build utils))
+
+       (set-path-environment-variable "PATH" '("bin" "sbin")
+                                      (map cdr %build-inputs))
+
+       (let ((graphs ',(match inputs-to-copy
+                         (((names . _) ...)
+                          names))))
+         (initialize-hard-disk #:grub.cfg ,grub-configuration
+                               #:closures-to-copy graphs
+                               #:disk-image-size ,disk-image-size
+                               #:initialize-store? ,initialize-store?
+                               #:directives ',populate)
+         (reboot)))
     #:system system
     #:inputs `(("parted" ,parted)
                ("grub" ,grub)
diff --git a/guix/build/vm.scm b/guix/build/vm.scm
index 725ede4e1f..33c898d968 100644
--- a/guix/build/vm.scm
+++ b/guix/build/vm.scm
@@ -17,9 +17,14 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix build vm)
-  #:use-module (ice-9 match)
   #:use-module (guix build utils)
-  #:export (load-in-linux-vm))
+  #:use-module (guix build linux-initrd)
+  #: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
+            initialize-hard-disk))
 
 ;;; Commentary:
 ;;;
@@ -94,4 +99,134 @@ the #:references-graphs parameter of 'derivation'."
         (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
+                                     #:key
+                                     (label-type "msdos")
+                                     partition-size)
+  "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)))
+
+(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 (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"))
+
+  (display "mounting partition...\n")
+  (mkdir "/fs")
+  (mount "/dev/sda1" "/fs" "ext3")
+
+  (when (pair? closures-to-copy)
+    ;; Populate the store.
+    (populate-store (map (cut string-append "/xchg/" <>)
+                         closures-to-copy)
+                    "/fs"))
+
+  ;; Populate /dev.
+  (make-essential-device-nodes #:root "/fs")
+
+  ;; Optionally, register the inputs in the image's store.
+  (when initialize-store?
+    (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))
+
+  ;; Evaluate the POPULATE directives.
+  (for-each (cut evaluate-populate-directive <> "/fs")
+            directives)
+
+  (unless (install-grub grub.cfg "/dev/sda" "/fs")
+    (error "failed to install GRUB"))
+
+  (reset-timestamps "/fs")
+
+  (zero? (system* "umount" "/fs")))
+
 ;;; vm.scm ends here