This small refactor should simplify some duplicated effort across functions and
allow smarter qemu-image to do smarter things based on the operating system
configuration rather than having each function that uses qemu-image pass
selective parameters whenever new information is needed.
* gnu/system/vm.scm (qemu-image): Replace os-derivation, grub-configuration and
inputs parameters with os-configuration, base-inputs and extra-inputs.
(qemu-image): Based on base-inputs, generate grub.cfg and os-drv.
(system-disk-image, system-qemu-image, system-qemu-image/shared-store):
Pass in the operating system configuration and base-inputs to qemu-image
instead of derivations.
---
gnu/system/vm.scm | 178 ++++++++++++++++++++++++++----------------------------
1 file changed, 86 insertions(+), 92 deletions(-)
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 58a476a..f4bf045 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <l...@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cweb...@dustycloud.org>
;;; Copyright © 2016 Leo Famulari <l...@famulari.name>
+;;; Copyright © 2016 Jookia <166...@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -193,68 +194,78 @@ made available under the /xchg CIFS share."
(disk-image-format "qcow2")
(file-system-type "ext4")
file-system-label
- os-derivation
- grub-configuration
+ os-configuration
(register-closures? #t)
- (inputs '())
+ (base-inputs (list 'grub.cfg 'system))
+ (extra-inputs '())
copy-inputs?)
"Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
-partition. The returned image is a full disk image that runs OS-DERIVATION,
-with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
-file (GRUB-CONFIGURATION must be the name of a file in the VM.)
+partition. The returned image is a full disk image that runs OS-CONFIGURATION,
+with a GRUB installation that uses its associated GRUB-CONFIGURATION.
-INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
+BASE-INPUTS is a list of inputs to be generated by qemu-image. By default it
+contains 'grub.cfg which includes the GRUB bootloader configuration file and
+'system which includes the derivation of the operating system configuration.
+EXTRA-INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is
true, copy
all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
register INPUTS in the store database of the image so that Guix can be used in
the image."
- (expression->derivation-in-linux-vm
- name
- #~(begin
- (use-modules (gnu build vm)
- (guix build utils))
-
- (let ((inputs
- '#$(append (list qemu parted grub e2fsprogs)
- (map canonical-package
- (list sed grep coreutils findutils gawk))
- (if register-closures? (list guix) '())))
-
- ;; This variable is unused but allows us to add INPUTS-TO-COPY
- ;; as inputs.
- (to-register
- '#$(map (match-lambda
- ((name thing) thing)
- ((name thing output) `(,thing ,output)))
- inputs)))
-
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
-
- (let* ((graphs '#$(match inputs
- (((names . _) ...)
- names)))
- (initialize (root-partition-initializer
- #:closures graphs
- #:copy-closures? #$copy-inputs?
- #:register-closures? #$register-closures?
- #:system-directory #$os-derivation))
- (partitions (list (partition
- (size #$(- disk-image-size
- (* 10 (expt 2 20))))
- (label #$file-system-label)
- (file-system #$file-system-type)
- (bootable? #t)
- (initializer initialize)))))
- (initialize-hard-disk "/dev/vda"
- #:partitions partitions
- #:grub.cfg #$grub-configuration)
- (reboot))))
- #:system system
- #:make-disk-image? #t
- #:disk-image-size disk-image-size
- #:disk-image-format disk-image-format
- #:references-graphs inputs))
+ (mlet* %store-monad ((os-drv (operating-system-derivation
os-configuration))
+ (grub.cfg (operating-system-grub.cfg os-configuration))
+ (inputs -> (append
+ (if (member 'grub.cfg base-inputs)
+ `(("grub.cfg" ,grub.cfg)) '())
+ (if (member 'system base-inputs)
+ `(("system" ,os-drv)) '())
+ extra-inputs)))
+ (expression->derivation-in-linux-vm
+ name
+ #~(begin
+ (use-modules (gnu build vm)
+ (guix build utils))
+
+ (let ((inputs
+ '#$(append (list qemu parted grub e2fsprogs)
+ (map canonical-package
+ (list sed grep coreutils findutils gawk))
+ (if register-closures? (list guix) '())))
+
+ ;; This variable is unused but allows us to add INPUTS-TO-COPY
+ ;; as inputs.
+ (to-register
+ '#$(map (match-lambda
+ ((name thing) thing)
+ ((name thing output) `(,thing ,output)))
+ inputs)))
+
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+
+ (let* ((graphs '#$(match inputs
+ (((names . _) ...)
+ names)))
+ (initialize (root-partition-initializer
+ #:closures graphs
+ #:copy-closures? #$copy-inputs?
+ #:register-closures? #$register-closures?
+ #:system-directory #$os-drv))
+ (partitions (list (partition
+ (size #$(- disk-image-size
+ (* 10 (expt 2 20))))
+ (label #$file-system-label)
+ (file-system #$file-system-type)
+ (bootable? #t)
+ (initializer initialize)))))
+ (initialize-hard-disk "/dev/vda"
+ #:partitions partitions
+ #:grub.cfg #$grub.cfg)
+ (reboot))))
+ #:system system
+ #:make-disk-image? #t
+ #:disk-image-size disk-image-size
+ #:disk-image-format disk-image-format
+ #:references-graphs inputs)))
;;;
@@ -299,19 +310,14 @@ to USB sticks meant to be read-only."
(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 #:name name
- #:os-derivation os-drv
- #:grub-configuration grub.cfg
- #:disk-image-size disk-image-size
- #:disk-image-format "raw"
- #:file-system-type file-system-type
- #:file-system-label root-label
- #:copy-inputs? #t
- #:register-closures? #t
- #:inputs `(("system" ,os-drv)
- ("grub.cfg" ,grub.cfg))))))
+ (qemu-image #:name name
+ #:os-configuration os
+ #:disk-image-size disk-image-size
+ #:disk-image-format "raw"
+ #:file-system-type file-system-type
+ #:file-system-label root-label
+ #:copy-inputs? #t
+ #:register-closures? #t)))
(define* (system-qemu-image os
#:key
@@ -343,16 +349,10 @@ of the GNU system as described by OS."
(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 #:os-derivation os-drv
- #:grub-configuration grub.cfg
- #:disk-image-size disk-image-size
- #:file-system-type file-system-type
- #:inputs `(("system" ,os-drv)
- ("grub.cfg" ,grub.cfg))
- #:copy-inputs? #t))))
+ (qemu-image #:os-configuration os
+ #:disk-image-size disk-image-size
+ #:file-system-type file-system-type
+ #:copy-inputs? #t)))
;;;
@@ -432,22 +432,16 @@ with the host.
When FULL-BOOT? is true, return an image that does a complete boot sequence,
bootloaded included; thus, make a disk image that contains everything the
bootloader refers to: OS kernel, initrd, bootloader data, etc."
- (mlet* %store-monad ((os-drv (operating-system-derivation os))
- (grub.cfg (operating-system-grub.cfg os)))
- ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
- ;; GRUB.CFG and all its dependencies, including the output of OS-DRV.
- ;; This is more than needed (we only need the kernel, initrd, GRUB for its
- ;; font, and the background image), but it's hard to filter that.
- (qemu-image #:os-derivation os-drv
- #:grub-configuration grub.cfg
- #:disk-image-size disk-image-size
- #:inputs (if full-boot?
- `(("grub.cfg" ,grub.cfg))
- '())
-
- ;; XXX: Passing #t here is too slow, so let it off by default.
- #:register-closures? #f
- #:copy-inputs? full-boot?)))
+ ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
+ ;; GRUB.CFG and all its dependencies, including the output of OS-DRV.
+ ;; This is more than needed (we only need the kernel, initrd, GRUB for its
+ ;; font, and the background image), but it's hard to filter that.
+ (qemu-image #:os-configuration os
+ #:disk-image-size disk-image-size
+ #:base-inputs (if full-boot? (list 'grub.cfg) '())
+ ;; XXX: Passing #t here is too slow, so let it off by default.
+ #:register-closures? #f
+ #:copy-inputs? full-boot?))
(define* (common-qemu-options image shared-fs)
"Return the a string-value gexp with the common QEMU options to boot IMAGE,
--
2.7.0
