diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2014-05-22 23:12:36 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2014-05-22 23:24:13 +0200 |
| commit | 1e77fedb46af3c131b46da7ced55f7078d0d0e5f (patch) | |
| tree | cd022f0b689b635ef5af918476954a123e967f46 /gnu/system | |
| parent | c9384945984c393ef1a15efb5c07e272a27a2215 (diff) | |
vm: Add 'system-disk-image'.
* gnu/system/vm.scm (system-disk-image): New procedure.
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/vm.scm | 40 |
1 files changed, 38 insertions, 2 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 7d0ffd971e..18635fd7e9 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -54,7 +54,8 @@ qemu-image system-qemu-image system-qemu-image/shared-store - system-qemu-image/shared-store-script)) + system-qemu-image/shared-store-script + system-disk-image)) ;;; Commentary: @@ -252,9 +253,44 @@ the image." ;;; -;;; Stand-alone VM image. +;;; VM and disk images. ;;; +(define* (system-disk-image os + #:key + (file-system-type "ext4") + (disk-image-size (* 900 (expt 2 20))) + (volatile? #t)) + "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the +system described by OS. Said image can be copied on a USB stick as is. When +VOLATILE? is true, the root file system is made volatile; this is useful +to USB sticks meant to be read-only." + (define file-systems-to-keep + (remove (lambda (fs) + (string=? (file-system-mount-point fs) "/")) + (operating-system-file-systems os))) + + (let ((os (operating-system (inherit os) + (initrd (cut qemu-initrd <> #:volatile-root? volatile?)) + + ;; Force our own root file system. + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/sda1") + (type file-system-type)) + file-systems-to-keep))))) + + (mlet* %store-monad ((os-drv (operating-system-derivation os)) + (grub.cfg (operating-system-grub.cfg os))) + (qemu-image #:grub-configuration grub.cfg + #:disk-image-size disk-image-size + #:disk-image-format "raw" + #:file-system-type file-system-type + #:copy-inputs? #t + #:register-closures? #t + #:inputs `(("system" ,os-drv) + ("grub.cfg" ,grub.cfg)))))) + (define* (system-qemu-image os #:key (file-system-type "ext4") |