summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-05-15 22:55:14 +0200
committerLudovic Courtès <ludo@gnu.org>2014-05-15 22:55:14 +0200
commit150e20ddde726abdfe77fa666351738cccb06281 (patch)
tree8d0eae0a8f46d2de4b402bec73a7f7eabf9e048d
parentc336a66fe825e062052f0812cc729c5b04411117 (diff)
downloadpatches-150e20ddde726abdfe77fa666351738cccb06281.tar
patches-150e20ddde726abdfe77fa666351738cccb06281.tar.gz
vm: Support initialization of the store DB when the store is shared.
* gnu/system/vm.scm (qemu-image): Rename #:inputs-to-copy to #:inputs, and #:initialize-store? to #:register-closures?. Add #:copy-inputs?. Adjust build gexp accordingly. (system-qemu-image): Remove #:initialize-store? argument and add #:copy-inputs?. (system-qemu-image/shared-store): Add #:inputs, #:register-closures?, and #:copy-inputs? arguments. * guix/build/vm.scm (register-closure): New procedure. (MS_BIND): New variable. (initialize-hard-disk): Rename #:initialize-store? to #:register-closures?, #:closures-to-copy to #:closures, and add #:copy-closures?. Add 'target-directory' and 'target-store' variables. Call 'populate-store' only when COPY-CLOSURES?. Bind-mount the store to TARGET-STORE when REGISTER-CLOSURES? and not COPY-CLOSURES?. Add call to 'register-closure'.
-rw-r--r--gnu/system/vm.scm40
-rw-r--r--guix/build/vm.scm68
2 files changed, 72 insertions, 36 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index f42feb394c..7008c5dab2 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -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
diff --git a/guix/build/vm.scm b/guix/build/vm.scm
index 1d1abad1dd..2c13a8904b 100644
--- a/guix/build/vm.scm
+++ b/guix/build/vm.scm
@@ -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