guix-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[PATCH] vm: Have qemu-image generate derivations instead.


From: Jookia
Subject: [PATCH] vm: Have qemu-image generate derivations instead.
Date: Thu, 11 Feb 2016 11:41:53 +0000

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 | 177 ++++++++++++++++++++++++++----------------------------
 1 file changed, 85 insertions(+), 92 deletions(-)

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index a7c03bd..4c3fd87 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -191,68 +191,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)))
 
 
 ;;;
@@ -297,19 +307,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
@@ -341,16 +346,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)))
 
 
 ;;;
@@ -430,22 +429,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




reply via email to

[Prev in Thread] Current Thread [Next in Thread]