~ruther/guix-local: vm: Provide a root partition for the freestanding VM image.

66f23d66219533aff689a05d16439827da1a2a59 — Ludovic Courtès 12 years ago 03ddfaf

vm: Provide a root partition for the freestanding VM image.

Fixes a regression introduced in 83bcd0b.

* gnu/system/vm.scm (system-qemu-image): Override the 'file-systems'
  field of OS.  Add #:file-system-type parameter and honor it.

patch browse .tar.gz

1 files changed, 22 insertions(+), 13 deletions(-)

M gnu/system/vm.scm

M gnu/system/vm.scm => gnu/system/vm.scm +22 -13

@@ 296,19 296,28 @@ basic contents of the root file system of OS."
                               (operating-system-users os))))))
 
 (define* (system-qemu-image os
-                            #:key (disk-image-size (* 900 (expt 2 20))))
-  "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU
-system as described by OS."
-  (mlet* %store-monad
-      ((os-drv      (operating-system-derivation os))
-       (os-dir   -> (derivation->output-path os-drv))
-       (grub.cfg -> (string-append os-dir "/grub.cfg"))
-       (populate    (operating-system-default-contents os)))
-    (qemu-image  #:grub-configuration grub.cfg
-                 #:populate populate
-                 #:disk-image-size disk-image-size
-                 #:initialize-store? #t
-                 #:inputs-to-copy `(("system" ,os-drv)))))
+                            #:key
+                            (file-system-type "ext4")
+                            (disk-image-size (* 900 (expt 2 20))))
+  "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
+of the GNU system as described by OS."
+  (let ((os (operating-system (inherit os)
+              ;; The mounted file systems are under our control.
+              (file-systems (list (file-system
+                                    (mount-point "/")
+                                    (device "/dev/sda1")
+                                    (type file-system-type)))))))
+    (mlet* %store-monad
+        ((os-drv      (operating-system-derivation os))
+         (os-dir   -> (derivation->output-path os-drv))
+         (grub.cfg -> (string-append os-dir "/grub.cfg"))
+         (populate    (operating-system-default-contents os)))
+      (qemu-image  #:grub-configuration grub.cfg
+                   #:populate populate
+                   #:disk-image-size disk-image-size
+                   #:file-system-type file-system-type
+                   #:initialize-store? #t
+                   #:inputs-to-copy `(("system" ,os-drv))))))
 
 (define (virtualized-operating-system os)
   "Return an operating system based on OS suitable for use in a virtualized