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'.

1 files changed, 15 insertions, 148 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)