aboutsummaryrefslogtreecommitdiff
path: root/gnu/system/vm.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system/vm.scm')
-rw-r--r--gnu/system/vm.scm166
1 files changed, 80 insertions, 86 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 676e89df98..c31e3a80ef 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -90,6 +90,21 @@
(options "trans=virtio")
(check? #f))))
+(define %vm-module-closure
+ ;; The closure of (gnu build vm), roughly.
+ ;; FIXME: Compute it automatically.
+ '((gnu build vm)
+ (gnu build install)
+ (gnu build linux-boot)
+ (gnu build linux-modules)
+ (gnu build file-systems)
+ (guix elf)
+ (guix records)
+ (guix build utils)
+ (guix build syscalls)
+ (guix build bournish)
+ (guix build store-copy)))
+
(define* (expression->derivation-in-linux-vm name exp
#:key
(system (%current-system))
@@ -97,18 +112,6 @@
initrd
(qemu qemu-minimal)
(env-vars '())
- (modules
- '((gnu build vm)
- (gnu build install)
- (gnu build linux-boot)
- (gnu build linux-modules)
- (gnu build file-systems)
- (guix elf)
- (guix records)
- (guix build utils)
- (guix build syscalls)
- (guix build bournish)
- (guix build store-copy)))
(guile-for-build
(%guile-for-build))
@@ -128,23 +131,13 @@ When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
return it.
-MODULES is the set of modules imported in the execution environment of EXP.
-
When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs, as for `derivation'. The files containing the reference graphs are
made available under the /xchg CIFS share."
(mlet* %store-monad
- ((module-dir (imported-modules modules))
- (compiled (compiled-modules modules))
- (user-builder (gexp->file "builder-in-linux-vm" exp))
+ ((user-builder (gexp->file "builder-in-linux-vm" exp))
(loader (gexp->file "linux-vm-loader"
- #~(begin
- (set! %load-path
- (cons #$module-dir %load-path))
- (set! %load-compiled-path
- (cons #$compiled
- %load-compiled-path))
- (primitive-load #$user-builder))))
+ #~(primitive-load #$user-builder)))
(coreutils -> (canonical-package coreutils))
(initrd (if initrd ; use the default initrd?
(return initrd)
@@ -155,34 +148,34 @@ made available under the /xchg CIFS share."
(define builder
;; Code that launches the VM that evaluates EXP.
- #~(begin
- (use-modules (guix build utils)
- (gnu build vm))
-
- (let ((inputs '#$(list qemu coreutils))
- (linux (string-append #$linux "/bzImage"))
- (initrd (string-append #$initrd "/initrd"))
- (loader #$loader)
- (graphs '#$(match references-graphs
- (((graph-files . _) ...) graph-files)
- (_ #f))))
-
- (set-path-environment-variable "PATH" '("bin") inputs)
-
- (load-in-linux-vm loader
- #:output #$output
- #:linux linux #:initrd initrd
- #:memory-size #$memory-size
- #:make-disk-image? #$make-disk-image?
- #:disk-image-format #$disk-image-format
- #:disk-image-size #$disk-image-size
- #:references-graphs graphs))))
+ (with-imported-modules %vm-module-closure
+ #~(begin
+ (use-modules (guix build utils)
+ (gnu build vm))
+
+ (let ((inputs '#$(list qemu coreutils))
+ (linux (string-append #$linux "/bzImage"))
+ (initrd (string-append #$initrd "/initrd"))
+ (loader #$loader)
+ (graphs '#$(match references-graphs
+ (((graph-files . _) ...) graph-files)
+ (_ #f))))
+
+ (set-path-environment-variable "PATH" '("bin") inputs)
+
+ (load-in-linux-vm loader
+ #:output #$output
+ #:linux linux #:initrd initrd
+ #:memory-size #$memory-size
+ #:make-disk-image? #$make-disk-image?
+ #:disk-image-format #$disk-image-format
+ #:disk-image-size #$disk-image-size
+ #:references-graphs graphs)))))
(gexp->derivation name builder
;; TODO: Require the "kvm" feature.
#:system system
#:env-vars env-vars
- #:modules modules
#:guile-for-build guile-for-build
#:references-graphs references-graphs)))
@@ -212,45 +205,46 @@ 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))))
+ (with-imported-modules %vm-module-closure
+ #~(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
generated by cgit v1.2.3 (git 2.45.0) at 2024-12-11 18:34:15 +0000