Commit | Line | Data |
---|---|---|
e1a87b90 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
548f7a8f | 19 | (define-module (gnu build vm) |
e1a87b90 | 20 | #:use-module (guix build utils) |
6fd1a796 | 21 | #:use-module (guix build store-copy) |
8a9e21d1 | 22 | #:use-module (gnu build linux-boot) |
548f7a8f | 23 | #:use-module (gnu build install) |
55651ff2 | 24 | #:use-module (ice-9 match) |
66670cf3 | 25 | #:use-module (ice-9 regex) |
55651ff2 | 26 | #:use-module (srfi srfi-26) |
66670cf3 LC |
27 | #:export (qemu-command |
28 | load-in-linux-vm | |
641f9a2a LC |
29 | format-partition |
30 | initialize-root-partition | |
31 | initialize-partition-table | |
55651ff2 | 32 | initialize-hard-disk)) |
e1a87b90 LC |
33 | |
34 | ;;; Commentary: | |
35 | ;;; | |
36 | ;;; This module provides supporting code to run virtual machines and build | |
37 | ;;; virtual machine images using QEMU. | |
38 | ;;; | |
39 | ;;; Code: | |
40 | ||
66670cf3 LC |
41 | (define* (qemu-command #:optional (system %host-type)) |
42 | "Return the default name of the QEMU command for SYSTEM." | |
43 | (let ((cpu (substring %host-type 0 | |
44 | (string-index %host-type #\-)))) | |
45 | (string-append "qemu-system-" | |
46 | (if (string-match "^i[3456]86$" cpu) | |
47 | "i386" | |
48 | cpu)))) | |
e1a87b90 LC |
49 | |
50 | (define* (load-in-linux-vm builder | |
51 | #:key | |
52 | output | |
53 | (qemu (qemu-command)) (memory-size 512) | |
54 | linux initrd | |
55 | make-disk-image? (disk-image-size 100) | |
c4a74364 | 56 | (disk-image-format "qcow2") |
e1a87b90 LC |
57 | (references-graphs '())) |
58 | "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy | |
59 | the result to OUTPUT. | |
60 | ||
61 | When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of | |
62 | DISK-IMAGE-SIZE MiB resulting from the execution of BUILDER, which may access | |
63 | it via /dev/hda. | |
64 | ||
65 | REFERENCES-GRAPHS can specify a list of reference-graph files as produced by | |
66 | the #:references-graphs parameter of 'derivation'." | |
c4a74364 LC |
67 | (define image-file |
68 | (string-append "image." disk-image-format)) | |
e1a87b90 LC |
69 | |
70 | (when make-disk-image? | |
c4a74364 LC |
71 | (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format |
72 | image-file | |
e1a87b90 LC |
73 | (number->string disk-image-size))) |
74 | (error "qemu-img failed"))) | |
75 | ||
76 | (mkdir "xchg") | |
77 | ||
78 | (match references-graphs | |
79 | ((graph-files ...) | |
80 | ;; Copy the reference-graph files under xchg/ so EXP can access it. | |
81 | (map (lambda (file) | |
82 | (copy-file file (string-append "xchg/" file))) | |
83 | graph-files)) | |
84 | (_ #f)) | |
85 | ||
86 | (unless (zero? | |
87 | (apply system* qemu "-enable-kvm" "-nographic" "-no-reboot" | |
88 | "-m" (number->string memory-size) | |
89 | "-net" "nic,model=virtio" | |
90 | "-virtfs" | |
91 | (string-append "local,id=store_dev,path=" | |
92 | (%store-directory) | |
93 | ",security_model=none,mount_tag=store") | |
94 | "-virtfs" | |
95 | (string-append "local,id=xchg_dev,path=xchg" | |
96 | ",security_model=none,mount_tag=xchg") | |
97 | "-kernel" linux | |
98 | "-initrd" initrd | |
99 | "-append" (string-append "console=ttyS0 --load=" | |
100 | builder) | |
101 | (if make-disk-image? | |
f19c6e5f LC |
102 | `("-drive" ,(string-append "file=" image-file |
103 | ",if=virtio")) | |
e1a87b90 LC |
104 | '()))) |
105 | (error "qemu failed" qemu)) | |
106 | ||
107 | (if make-disk-image? | |
c4a74364 | 108 | (copy-file image-file output) |
e1a87b90 LC |
109 | (begin |
110 | (mkdir output) | |
111 | (copy-recursively "xchg" output)))) | |
112 | ||
641f9a2a | 113 | (define* (initialize-partition-table device partition-size |
55651ff2 | 114 | #:key |
bff39668 | 115 | bootable? |
55651ff2 | 116 | (label-type "msdos") |
641f9a2a | 117 | (offset (expt 2 20))) |
55651ff2 | 118 | "Create on DEVICE a partition table of type LABEL-TYPE, with a single |
bff39668 LC |
119 | partition of PARTITION-SIZE bytes starting at OFFSET bytes. When BOOTABLE? is |
120 | true, set the bootable flag on the partition. Return #t on success." | |
641f9a2a LC |
121 | (format #t "creating partition table with a ~a B partition...\n" |
122 | partition-size) | |
bff39668 LC |
123 | (unless (zero? (apply system* "parted" device "mklabel" label-type |
124 | "mkpart" "primary" "ext2" | |
125 | (format #f "~aB" offset) | |
126 | (format #f "~aB" partition-size) | |
127 | (if bootable? | |
128 | '("set" "1" "boot" "on") | |
129 | '()))) | |
641f9a2a | 130 | (error "failed to create partition table"))) |
55651ff2 | 131 | |
150e20dd LC |
132 | (define MS_BIND 4096) ; <sys/mounts.h> again! |
133 | ||
ef9fc40d LC |
134 | (define* (format-partition partition type |
135 | #:key label) | |
136 | "Create a file system TYPE on PARTITION. If LABEL is true, use that as the | |
137 | volume name." | |
641f9a2a | 138 | (format #t "creating ~a partition...\n" type) |
ef9fc40d LC |
139 | (unless (zero? (apply system* (string-append "mkfs." type) |
140 | "-F" partition | |
141 | (if label | |
142 | `("-L" ,label) | |
143 | '()))) | |
641f9a2a | 144 | (error "failed to create partition"))) |
150e20dd | 145 | |
641f9a2a LC |
146 | (define* (initialize-root-partition target-directory |
147 | #:key copy-closures? register-closures? | |
f2c403ea | 148 | closures system-directory) |
641f9a2a | 149 | "Initialize the root partition mounted at TARGET-DIRECTORY." |
150e20dd LC |
150 | (define target-store |
151 | (string-append target-directory (%store-directory))) | |
152 | ||
150e20dd | 153 | (when copy-closures? |
55651ff2 | 154 | ;; Populate the store. |
150e20dd LC |
155 | (populate-store (map (cut string-append "/xchg/" <>) closures) |
156 | target-directory)) | |
55651ff2 LC |
157 | |
158 | ;; Populate /dev. | |
150e20dd | 159 | (make-essential-device-nodes #:root target-directory) |
55651ff2 LC |
160 | |
161 | ;; Optionally, register the inputs in the image's store. | |
150e20dd LC |
162 | (when register-closures? |
163 | (unless copy-closures? | |
164 | ;; XXX: 'guix-register' wants to palpate the things it registers, so | |
165 | ;; bind-mount the store on the target. | |
166 | (mkdir-p target-store) | |
167 | (mount (%store-directory) target-store "" MS_BIND)) | |
168 | ||
169 | (display "registering closures...\n") | |
55651ff2 | 170 | (for-each (lambda (closure) |
150e20dd LC |
171 | (register-closure target-directory |
172 | (string-append "/xchg/" closure))) | |
173 | closures) | |
174 | (unless copy-closures? | |
175 | (system* "umount" target-store))) | |
55651ff2 | 176 | |
641f9a2a | 177 | ;; Add the non-store directories and files. |
150e20dd | 178 | (display "populating...\n") |
f2c403ea | 179 | (populate-root-file-system system-directory target-directory)) |
641f9a2a | 180 | |
6412e58a LC |
181 | (define (register-grub.cfg-root target grub.cfg) |
182 | "On file system TARGET, register GRUB.CFG as a GC root." | |
183 | (let ((directory (string-append target "/var/guix/gcroots"))) | |
39d1f82b | 184 | (mkdir-p directory) |
6412e58a | 185 | (symlink grub.cfg (string-append directory "/grub.cfg")))) |
39d1f82b | 186 | |
641f9a2a LC |
187 | (define* (initialize-hard-disk device |
188 | #:key | |
f2c403ea | 189 | system-directory |
641f9a2a LC |
190 | grub.cfg |
191 | disk-image-size | |
192 | (file-system-type "ext4") | |
ef9fc40d | 193 | file-system-label |
641f9a2a LC |
194 | (closures '()) |
195 | copy-closures? | |
bff39668 | 196 | (bootable? #t) |
641f9a2a | 197 | (register-closures? #t)) |
ef9fc40d LC |
198 | "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a FILE-SYSTEM-TYPE |
199 | partition with (optionally) FILE-SYSTEM-LABEL as its volume name, and with | |
bff39668 LC |
200 | GRUB installed. When BOOTABLE? is true, set the bootable flag on that |
201 | partition. | |
202 | ||
203 | If REGISTER-CLOSURES? is true, register all of CLOSURES is the partition's | |
204 | store. If COPY-CLOSURES? is true, copy all of CLOSURES to the partition. | |
205 | SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." | |
641f9a2a LC |
206 | (define target-directory |
207 | "/fs") | |
208 | ||
209 | (define partition | |
210 | (string-append device "1")) | |
211 | ||
212 | (initialize-partition-table device | |
bff39668 LC |
213 | (- disk-image-size (* 5 (expt 2 20))) |
214 | #:bootable? bootable?) | |
641f9a2a | 215 | |
ef9fc40d LC |
216 | (format-partition partition file-system-type |
217 | #:label file-system-label) | |
641f9a2a LC |
218 | |
219 | (display "mounting partition...\n") | |
220 | (mkdir target-directory) | |
221 | (mount partition target-directory file-system-type) | |
222 | ||
223 | (initialize-root-partition target-directory | |
f2c403ea | 224 | #:system-directory system-directory |
641f9a2a LC |
225 | #:copy-closures? copy-closures? |
226 | #:register-closures? register-closures? | |
227 | #:closures closures) | |
55651ff2 | 228 | |
641f9a2a | 229 | (install-grub grub.cfg device target-directory) |
55651ff2 | 230 | |
6412e58a LC |
231 | ;; Register GRUB.CFG as a GC root. |
232 | (register-grub.cfg-root target-directory grub.cfg) | |
39d1f82b | 233 | |
15d29987 LC |
234 | ;; 'guix-register' resets timestamps and everything, so no need to do it |
235 | ;; once more in that case. | |
236 | (unless register-closures? | |
237 | (reset-timestamps target-directory)) | |
55651ff2 | 238 | |
150e20dd | 239 | (zero? (system* "umount" target-directory))) |
55651ff2 | 240 | |
e1a87b90 | 241 | ;;; vm.scm ends here |