diff options
Diffstat (limited to 'guix/build/vm.scm')
| -rw-r--r-- | guix/build/vm.scm | 177 |
1 files changed, 94 insertions, 83 deletions
diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 33c898d968..e559542f0a 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -19,11 +19,15 @@ (define-module (guix build vm) #:use-module (guix build utils) #:use-module (guix build linux-initrd) + #:use-module (guix build install) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (load-in-linux-vm + format-partition + initialize-root-partition + initialize-partition-table initialize-hard-disk)) ;;; Commentary: @@ -46,6 +50,7 @@ (qemu (qemu-command)) (memory-size 512) linux initrd make-disk-image? (disk-image-size 100) + (disk-image-format "qcow2") (references-graphs '())) "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy the result to OUTPUT. @@ -56,9 +61,12 @@ it via /dev/hda. REFERENCES-GRAPHS can specify a list of reference-graph files as produced by the #:references-graphs parameter of 'derivation'." + (define image-file + (string-append "image." disk-image-format)) (when make-disk-image? - (unless (zero? (system* "qemu-img" "create" "-f" "qcow2" "image.qcow2" + (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format + image-file (number->string disk-image-size))) (error "qemu-img failed"))) @@ -88,13 +96,13 @@ the #:references-graphs parameter of 'derivation'." "-append" (string-append "console=ttyS0 --load=" builder) (if make-disk-image? - '("-hda" "image.qcow2") + `("-drive" ,(string-append "file=" image-file + ",if=virtio")) '()))) (error "qemu failed" qemu)) (if make-disk-image? - (copy-file "image.qcow2" ; XXX: who mkdir'd OUTPUT? - output) + (copy-file image-file output) (begin (mkdir output) (copy-recursively "xchg" output)))) @@ -113,25 +121,20 @@ The data at PORT is the format produced by #:references-graphs." (loop (read-line port) result))))) -(define* (initialize-partition-table device +(define* (initialize-partition-table device partition-size #:key (label-type "msdos") - partition-size) + (offset (expt 2 20))) "Create on DEVICE a partition table of type LABEL-TYPE, with a single -partition of PARTITION-SIZE MiB. Return #t on success." - (display "creating partition table...\n") - (zero? (system* "parted" "/dev/sda" "mklabel" label-type - "mkpart" "primary" "ext2" "1MiB" - (format #f "~aB" partition-size)))) - -(define* (install-grub grub.cfg device mount-point) - "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on -MOUNT-POINT. Return #t on success." - (mkdir-p (string-append mount-point "/boot/grub")) - (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg")) - (zero? (system* "grub-install" "--no-floppy" - "--boot-directory" (string-append mount-point "/boot") - device))) +partition of PARTITION-SIZE bytes starting at OFFSET bytes. Return #t on +success." + (format #t "creating partition table with a ~a B partition...\n" + partition-size) + (unless (zero? (system* "parted" device "mklabel" label-type + "mkpart" "primary" "ext2" + (format #f "~aB" offset) + (format #f "~aB" partition-size))) + (error "failed to create partition table"))) (define* (populate-store reference-graphs target) "Populate the store under directory TARGET with the items specified in @@ -153,80 +156,88 @@ REFERENCE-GRAPHS, a list of reference-graph files." (string-append target thing))) (things-to-copy))) -(define (evaluate-populate-directive directive target) - "Evaluate DIRECTIVE, an sexp describing a file or directory to create under -directory TARGET." - (match directive - (('directory name) - (mkdir-p (string-append target name))) - (('directory name uid gid) - (let ((dir (string-append target name))) - (mkdir-p dir) - (chown dir uid gid))) - ((new '-> old) - (symlink old (string-append target new))))) - -(define (reset-timestamps directory) - "Reset the timestamps of all the files under DIRECTORY, so that they appear -as created and modified at the Epoch." - (display "clearing file timestamps...\n") - (for-each (lambda (file) - (let ((s (lstat file))) - ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so - ;; the timestamp of symlinks cannot be changed, and there are - ;; symlinks here pointing to /gnu/store, which is the host, - ;; read-only store. - (unless (eq? (stat:type s) 'symlink) - (utime file 0 0 0 0)))) - (find-files directory ""))) - -(define* (initialize-hard-disk #:key - grub.cfg - disk-image-size - (mkfs "mkfs.ext3") - initialize-store? - (closures-to-copy '()) - (directives '())) - (unless (initialize-partition-table "/dev/sda" - #:partition-size - (- disk-image-size (* 5 (expt 2 20)))) - (error "failed to create partition table")) - - (display "creating ext3 partition...\n") - (unless (zero? (system* mkfs "-F" "/dev/sda1")) - (error "failed to create partition")) +(define MS_BIND 4096) ; <sys/mounts.h> again! - (display "mounting partition...\n") - (mkdir "/fs") - (mount "/dev/sda1" "/fs" "ext3") +(define (format-partition partition type) + "Create a file system TYPE on PARTITION." + (format #t "creating ~a partition...\n" type) + (unless (zero? (system* (string-append "mkfs." type) "-F" partition)) + (error "failed to create partition"))) - (when (pair? closures-to-copy) +(define* (initialize-root-partition target-directory + #:key copy-closures? register-closures? + closures) + "Initialize the root partition mounted at TARGET-DIRECTORY." + (define target-store + (string-append target-directory (%store-directory))) + + (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))) + + ;; Add the non-store directories and files. + (display "populating...\n") + (populate-root-file-system target-directory)) + +(define* (initialize-hard-disk device + #:key + grub.cfg + disk-image-size + (file-system-type "ext4") + (closures '()) + copy-closures? + (register-closures? #t)) + "Initialize DEVICE, 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." + (define target-directory + "/fs") + + (define partition + (string-append device "1")) + + (initialize-partition-table device + (- disk-image-size (* 5 (expt 2 20)))) + + (format-partition partition file-system-type) + + (display "mounting partition...\n") + (mkdir target-directory) + (mount partition target-directory file-system-type) - ;; Evaluate the POPULATE directives. - (for-each (cut evaluate-populate-directive <> "/fs") - directives) + (initialize-root-partition target-directory + #:copy-closures? copy-closures? + #:register-closures? register-closures? + #:closures closures) - (unless (install-grub grub.cfg "/dev/sda" "/fs") - (error "failed to install GRUB")) + (install-grub grub.cfg device target-directory) - (reset-timestamps "/fs") + ;; 'guix-register' resets timestamps and everything, so no need to do it + ;; once more in that case. + (unless register-closures? + (reset-timestamps target-directory)) - (zero? (system* "umount" "/fs"))) + (zero? (system* "umount" target-directory))) ;;; vm.scm ends here |