M gnu/system/vm.scm => gnu/system/vm.scm +23 -17
@@ 192,25 192,26 @@ made available under the /xchg CIFS share."
(disk-image-size (* 100 (expt 2 20)))
(file-system-type "ext4")
grub-configuration
- (initialize-store? #f)
+ (register-closures? #t)
(populate #f)
- (inputs-to-copy '()))
+ (inputs '())
+ copy-inputs?)
"Return a bootable, stand-alone QEMU image, with a root partition of type
FILE-SYSTEM-TYPE. The returned image is a full disk image, with a GRUB
installation that uses GRUB-CONFIGURATION as its configuration
file (GRUB-CONFIGURATION must be the name of a file in the VM.)
-INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
-into the image being built. When INITIALIZE-STORE? is true, initialize the
-store database in the image so that Guix can be used in the image.
+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.
POPULATE is a list of directives stating directories or symlinks to be created
in the disk image partition. It is evaluated once the image has been
populated with INPUTS-TO-COPY. It can be used to provide additional files,
such as /etc files."
(mlet %store-monad
- ((graph (sequence %store-monad
- (map input->name+output inputs-to-copy))))
+ ((graph (sequence %store-monad (map input->name+output inputs))))
(expression->derivation-in-linux-vm
name
#~(begin
@@ 221,26 222,27 @@ such as /etc files."
'#$(append (list qemu parted grub e2fsprogs util-linux)
(map (compose car (cut assoc-ref %final-inputs <>))
'("sed" "grep" "coreutils" "findutils" "gawk"))
- (if initialize-store? (list guix) '())))
+ (if register-closures? (list guix) '())))
;; This variable is unused but allows us to add INPUTS-TO-COPY
;; as inputs.
- (to-copy
+ (to-register
'#$(map (match-lambda
((name thing) thing)
((name thing output) `(,thing ,output)))
- inputs-to-copy)))
+ inputs)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (let ((graphs '#$(match inputs-to-copy
+ (let ((graphs '#$(match inputs
(((names . _) ...)
names))))
(initialize-hard-disk #:grub.cfg #$grub-configuration
- #:closures-to-copy graphs
+ #:closures graphs
+ #:copy-closures? #$copy-inputs?
+ #:register-closures? #$register-closures?
#:disk-image-size #$disk-image-size
#:file-system-type #$file-system-type
- #:initialize-store? #$initialize-store?
#:directives '#$populate)
(reboot))))
#:system system
@@ 318,8 320,8 @@ of the GNU system as described by OS."
#:populate populate
#:disk-image-size disk-image-size
#:file-system-type file-system-type
- #:initialize-store? #t
- #:inputs-to-copy `(("system" ,os-drv))))))
+ #:inputs `(("system" ,os-drv))
+ #:copy-inputs? #t))))
(define (virtualized-operating-system os)
"Return an operating system based on OS suitable for use in a virtualized
@@ 358,10 360,14 @@ with the host."
(os-dir -> (derivation->output-path os-drv))
(grub.cfg -> (string-append os-dir "/grub.cfg"))
(populate (operating-system-default-contents os)))
- ;; TODO: Initialize the database so Guix can be used in the guest.
(qemu-image #:grub-configuration grub.cfg
#:populate populate
- #:disk-image-size disk-image-size)))
+ #:disk-image-size disk-image-size
+ #:inputs `(("system" ,os-drv))
+
+ ;; XXX: Passing #t here is too slow, so let it off by default.
+ #:register-closures? #f
+ #:copy-inputs? #f)))
(define* (system-qemu-image/shared-store-script
os
M guix/build/vm.scm => guix/build/vm.scm +49 -19
@@ 180,13 180,36 @@ as created and modified at the Epoch."
(utime file 0 0 0 0))))
(find-files directory "")))
+(define (register-closure store closure)
+ "Register CLOSURE in STORE, where STORE is the directory name of the target
+store and CLOSURE is the name of a file containing a reference graph as used
+by 'guix-register'."
+ (let ((status (system* "guix-register" "--prefix" store
+ closure)))
+ (unless (zero? status)
+ (error "failed to register store items" closure))))
+
+(define MS_BIND 4096) ; <sys/mounts.h> again!
+
(define* (initialize-hard-disk #:key
grub.cfg
disk-image-size
(file-system-type "ext4")
- initialize-store?
- (closures-to-copy '())
+ (closures '())
+ copy-closures?
+ (register-closures? #t)
(directives '()))
+ "Initialize /dev/sda, a disk of DISK-IMAGE-SIZE bytes, with a
+FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is
+true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is
+true, copy all of CLOSURES to the partition. Lastly, apply DIRECTIVES to
+further populate the partition."
+ (define target-directory
+ "/fs")
+
+ (define target-store
+ (string-append target-directory (%store-directory)))
+
(unless (initialize-partition-table "/dev/sda"
#:partition-size
(- disk-image-size (* 5 (expt 2 20))))
@@ 198,36 221,43 @@ as created and modified at the Epoch."
(error "failed to create partition"))
(display "mounting partition...\n")
- (mkdir "/fs")
- (mount "/dev/sda1" "/fs" file-system-type)
+ (mkdir target-directory)
+ (mount "/dev/sda1" target-directory file-system-type)
- (when (pair? closures-to-copy)
+ (when copy-closures?
;; Populate the store.
- (populate-store (map (cut string-append "/xchg/" <>)
- closures-to-copy)
- "/fs"))
+ (populate-store (map (cut string-append "/xchg/" <>) closures)
+ target-directory))
;; Populate /dev.
- (make-essential-device-nodes #:root "/fs")
+ (make-essential-device-nodes #:root target-directory)
;; Optionally, register the inputs in the image's store.
- (when initialize-store?
+ (when register-closures?
+ (unless copy-closures?
+ ;; XXX: 'guix-register' wants to palpate the things it registers, so
+ ;; bind-mount the store on the target.
+ (mkdir-p target-store)
+ (mount (%store-directory) target-store "" MS_BIND))
+
+ (display "registering closures...\n")
(for-each (lambda (closure)
- (let ((status (system* "guix-register" "--prefix" "/fs"
- (string-append "/xchg/" closure))))
- (unless (zero? status)
- (error "failed to register store items" closure))))
- closures-to-copy))
+ (register-closure target-directory
+ (string-append "/xchg/" closure)))
+ closures)
+ (unless copy-closures?
+ (system* "umount" target-store)))
;; Evaluate the POPULATE directives.
- (for-each (cut evaluate-populate-directive <> "/fs")
+ (display "populating...\n")
+ (for-each (cut evaluate-populate-directive <> target-directory)
directives)
- (unless (install-grub grub.cfg "/dev/sda" "/fs")
+ (unless (install-grub grub.cfg "/dev/sda" target-directory)
(error "failed to install GRUB"))
- (reset-timestamps "/fs")
+ (reset-timestamps target-directory)
- (zero? (system* "umount" "/fs")))
+ (zero? (system* "umount" target-directory)))
;;; vm.scm ends here