diff options
Diffstat (limited to 'gnu/build/vm.scm')
| -rw-r--r-- | gnu/build/vm.scm | 259 |
1 files changed, 259 insertions, 0 deletions
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm new file mode 100644 index 0000000000..d724ca3a55 --- /dev/null +++ b/gnu/build/vm.scm @@ -0,0 +1,259 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu build vm) + #:use-module (guix build utils) + #:use-module (gnu build linux-initrd) + #:use-module (gnu build install) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (qemu-command + load-in-linux-vm + format-partition + initialize-root-partition + initialize-partition-table + initialize-hard-disk)) + +;;; Commentary: +;;; +;;; This module provides supporting code to run virtual machines and build +;;; virtual machine images using QEMU. +;;; +;;; Code: + +(define* (qemu-command #:optional (system %host-type)) + "Return the default name of the QEMU command for SYSTEM." + (let ((cpu (substring %host-type 0 + (string-index %host-type #\-)))) + (string-append "qemu-system-" + (if (string-match "^i[3456]86$" cpu) + "i386" + cpu)))) + +(define* (load-in-linux-vm builder + #:key + output + (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. + +When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of +DISK-IMAGE-SIZE MiB resulting from the execution of BUILDER, which may access +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" disk-image-format + image-file + (number->string disk-image-size))) + (error "qemu-img failed"))) + + (mkdir "xchg") + + (match references-graphs + ((graph-files ...) + ;; Copy the reference-graph files under xchg/ so EXP can access it. + (map (lambda (file) + (copy-file file (string-append "xchg/" file))) + graph-files)) + (_ #f)) + + (unless (zero? + (apply system* qemu "-enable-kvm" "-nographic" "-no-reboot" + "-m" (number->string memory-size) + "-net" "nic,model=virtio" + "-virtfs" + (string-append "local,id=store_dev,path=" + (%store-directory) + ",security_model=none,mount_tag=store") + "-virtfs" + (string-append "local,id=xchg_dev,path=xchg" + ",security_model=none,mount_tag=xchg") + "-kernel" linux + "-initrd" initrd + "-append" (string-append "console=ttyS0 --load=" + builder) + (if make-disk-image? + `("-drive" ,(string-append "file=" image-file + ",if=virtio")) + '()))) + (error "qemu failed" qemu)) + + (if make-disk-image? + (copy-file image-file output) + (begin + (mkdir output) + (copy-recursively "xchg" output)))) + +(define (read-reference-graph port) + "Return a list of store paths from the reference graph at PORT. +The data at PORT is the format produced by #:references-graphs." + (let loop ((line (read-line port)) + (result '())) + (cond ((eof-object? line) + (delete-duplicates result)) + ((string-prefix? "/" line) + (loop (read-line port) + (cons line result))) + (else + (loop (read-line port) + result))))) + +(define* (initialize-partition-table device partition-size + #:key + (label-type "msdos") + (offset (expt 2 20))) + "Create on DEVICE a partition table of type LABEL-TYPE, with a single +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 +REFERENCE-GRAPHS, a list of reference-graph files." + (define store + (string-append target (%store-directory))) + + (define (things-to-copy) + ;; Return the list of store files to copy to the image. + (define (graph-from-file file) + (call-with-input-file file read-reference-graph)) + + (delete-duplicates (append-map graph-from-file reference-graphs))) + + (mkdir-p store) + (chmod store #o1775) + (for-each (lambda (thing) + (copy-recursively thing + (string-append target thing))) + (things-to-copy))) + +(define MS_BIND 4096) ; <sys/mounts.h> again! + +(define* (format-partition partition type + #:key label) + "Create a file system TYPE on PARTITION. If LABEL is true, use that as the +volume name." + (format #t "creating ~a partition...\n" type) + (unless (zero? (apply system* (string-append "mkfs." type) + "-F" partition + (if label + `("-L" ,label) + '()))) + (error "failed to create partition"))) + +(define* (initialize-root-partition target-directory + #:key copy-closures? register-closures? + closures system-directory) + "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) + target-directory)) + + ;; Populate /dev. + (make-essential-device-nodes #:root target-directory) + + ;; Optionally, register the inputs in the image's 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) + (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 system-directory target-directory)) + +(define* (initialize-hard-disk device + #:key + system-directory + grub.cfg + disk-image-size + (file-system-type "ext4") + file-system-label + (closures '()) + copy-closures? + (register-closures? #t)) + "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a FILE-SYSTEM-TYPE +partition with (optionally) FILE-SYSTEM-LABEL as its volume name, 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. SYSTEM-DIRECTORY is the name of the directory of the 'system' +derivation." + (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 + #:label file-system-label) + + (display "mounting partition...\n") + (mkdir target-directory) + (mount partition target-directory file-system-type) + + (initialize-root-partition target-directory + #:system-directory system-directory + #:copy-closures? copy-closures? + #:register-closures? register-closures? + #:closures closures) + + (install-grub grub.cfg device target-directory) + + ;; '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" target-directory))) + +;;; vm.scm ends here |