guix/guix
3
4
Fork 0
mirror of git://git.savannah.gnu.org/guix.git synced 2023-12-14 03:33:07 +01:00
Code Issues Releases Wiki Activity

vm: Add 'system-disk-image'.

Browse source 
* gnu/system/vm.scm (system-disk-image): New procedure.
This commit is contained in:
Ludovic Courtès 2014-05-22 23:12:36 +02:00
parent c938494598
commit 1e77fedb46
1 changed files with 38 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

40
gnu/system/vm.scm
View file

@ -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")