diff options
| -rw-r--r-- | gnu/system/vm.scm | 40 | ||||
| -rw-r--r-- | guix/build/vm.scm | 68 |
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 |