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) |
548f7a8f LC |
21 | #:use-module (gnu build linux-initrd) |
22 | #:use-module (gnu build install) | |
55651ff2 | 23 | #:use-module (ice-9 match) |
66670cf3 | 24 | #:use-module (ice-9 regex) |
55651ff2 LC |
25 | #:use-module (ice-9 rdelim) |
26 | #:use-module (srfi srfi-1) | |
27 | #:use-module (srfi srfi-26) | |
66670cf3 LC |
28 | #:export (qemu-command |
29 | load-in-linux-vm | |
641f9a2a LC |
30 | format-partition |
31 | initialize-root-partition | |
32 | initialize-partition-table | |
55651ff2 | 33 | initialize-hard-disk)) |
e1a87b90 LC |
34 | |
35 | ;;; Commentary: | |
36 | ;;; | |
37 | ;;; This module provides supporting code to run virtual machines and build | |
38 | ;;; virtual machine images using QEMU. | |
39 | ;;; | |
40 | ;;; Code: | |
41 | ||
66670cf3 LC |
42 | (define* (qemu-command #:optional (system %host-type)) |
43 | "Return the default name of the QEMU command for SYSTEM." | |
44 | (let ((cpu (substring %host-type 0 | |
45 | (string-index %host-type #\-)))) | |
46 | (string-append "qemu-system-" | |
47 | (if (string-match "^i[3456]86$" cpu) | |
48 | "i386" | |
49 | cpu)))) | |
e1a87b90 LC |
50 | |
51 | (define* (load-in-linux-vm builder | |
52 | #:key | |
53 | output | |
54 | (qemu (qemu-command)) (memory-size 512) | |
55 | linux initrd | |
56 | make-disk-image? (disk-image-size 100) | |
c4a74364 | 57 | (disk-image-format "qcow2") |
e1a87b90 LC |
58 | (references-graphs '())) |
59 | "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy | |
60 | the result to OUTPUT. | |
61 | ||
62 | When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of | |
63 | DISK-IMAGE-SIZE MiB resulting from the execution of BUILDER, which may access | |
64 | it via /dev/hda. | |
65 | ||
66 | REFERENCES-GRAPHS can specify a list of reference-graph files as produced by | |
67 | the #:references-graphs parameter of 'derivation'." | |
c4a74364 LC |
68 | (define image-file |
69 | (string-append "image." disk-image-format)) | |
e1a87b90 LC |
70 | |
71 | (when make-disk-image? | |
c4a74364 LC |
72 | (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format |
73 | image-file | |
e1a87b90 LC |
74 | (number->string disk-image-size))) |
75 | (error "qemu-img failed"))) | |
76 | ||
77 | (mkdir "xchg") | |
78 | ||
79 | (match references-graphs | |
80 | ((graph-files ...) | |
81 | ;; Copy the reference-graph files under xchg/ so EXP can access it. | |
82 | (map (lambda (file) | |
83 | (copy-file file (string-append "xchg/" file))) | |
84 | graph-files)) | |
85 | (_ #f)) | |
86 | ||
87 | (unless (zero? | |
88 | (apply system* qemu "-enable-kvm" "-nographic" "-no-reboot" | |
89 | "-m" (number->string memory-size) | |
90 | "-net" "nic,model=virtio" | |
91 | "-virtfs" | |
92 | (string-append "local,id=store_dev,path=" | |
93 | (%store-directory) | |
94 | ",security_model=none,mount_tag=store") | |
95 | "-virtfs" | |
96 | (string-append "local,id=xchg_dev,path=xchg" | |
97 | ",security_model=none,mount_tag=xchg") | |
98 | "-kernel" linux | |
99 | "-initrd" initrd | |
100 | "-append" (string-append "console=ttyS0 --load=" | |
101 | builder) | |
102 | (if make-disk-image? | |
f19c6e5f LC |
103 | `("-drive" ,(string-append "file=" image-file |
104 | ",if=virtio")) | |
e1a87b90 LC |
105 | '()))) |
106 | (error "qemu failed" qemu)) | |
107 | ||
108 | (if make-disk-image? | |
c4a74364 | 109 | (copy-file image-file output) |
e1a87b90 LC |
110 | (begin |
111 | (mkdir output) | |
112 | (copy-recursively "xchg" output)))) | |
113 | ||
55651ff2 LC |
114 | (define (read-reference-graph port) |
115 | "Return a list of store paths from the reference graph at PORT. | |
116 | The data at PORT is the format produced by #:references-graphs." | |
117 | (let loop ((line (read-line port)) | |
118 | (result '())) | |
119 | (cond ((eof-object? line) | |
120 | (delete-duplicates result)) | |
121 | ((string-prefix? "/" line) | |
122 | (loop (read-line port) | |
123 | (cons line result))) | |
124 | (else | |
125 | (loop (read-line port) | |
126 | result))))) | |
127 | ||
641f9a2a | 128 | (define* (initialize-partition-table device partition-size |
55651ff2 LC |
129 | #:key |
130 | (label-type "msdos") | |
641f9a2a | 131 | (offset (expt 2 20))) |
55651ff2 | 132 | "Create on DEVICE a partition table of type LABEL-TYPE, with a single |
641f9a2a LC |
133 | partition of PARTITION-SIZE bytes starting at OFFSET bytes. Return #t on |
134 | success." | |
135 | (format #t "creating partition table with a ~a B partition...\n" | |
136 | partition-size) | |
137 | (unless (zero? (system* "parted" device "mklabel" label-type | |
138 | "mkpart" "primary" "ext2" | |
139 | (format #f "~aB" offset) | |
140 | (format #f "~aB" partition-size))) | |
141 | (error "failed to create partition table"))) | |
55651ff2 | 142 | |
55651ff2 LC |
143 | (define* (populate-store reference-graphs target) |
144 | "Populate the store under directory TARGET with the items specified in | |
145 | REFERENCE-GRAPHS, a list of reference-graph files." | |
146 | (define store | |
147 | (string-append target (%store-directory))) | |
148 | ||
149 | (define (things-to-copy) | |
150 | ;; Return the list of store files to copy to the image. | |
151 | (define (graph-from-file file) | |
152 | (call-with-input-file file read-reference-graph)) | |
153 | ||
154 | (delete-duplicates (append-map graph-from-file reference-graphs))) | |
155 | ||
156 | (mkdir-p store) | |
157 | (chmod store #o1775) | |
158 | (for-each (lambda (thing) | |
159 | (copy-recursively thing | |
160 | (string-append target thing))) | |
161 | (things-to-copy))) | |
162 | ||
150e20dd LC |
163 | (define MS_BIND 4096) ; <sys/mounts.h> again! |
164 | ||
ef9fc40d LC |
165 | (define* (format-partition partition type |
166 | #:key label) | |
167 | "Create a file system TYPE on PARTITION. If LABEL is true, use that as the | |
168 | volume name." | |
641f9a2a | 169 | (format #t "creating ~a partition...\n" type) |
ef9fc40d LC |
170 | (unless (zero? (apply system* (string-append "mkfs." type) |
171 | "-F" partition | |
172 | (if label | |
173 | `("-L" ,label) | |
174 | '()))) | |
641f9a2a | 175 | (error "failed to create partition"))) |
150e20dd | 176 | |
641f9a2a LC |
177 | (define* (initialize-root-partition target-directory |
178 | #:key copy-closures? register-closures? | |
f2c403ea | 179 | closures system-directory) |
641f9a2a | 180 | "Initialize the root partition mounted at TARGET-DIRECTORY." |
150e20dd LC |
181 | (define target-store |
182 | (string-append target-directory (%store-directory))) | |
183 | ||
150e20dd | 184 | (when copy-closures? |
55651ff2 | 185 | ;; Populate the store. |
150e20dd LC |
186 | (populate-store (map (cut string-append "/xchg/" <>) closures) |
187 | target-directory)) | |
55651ff2 LC |
188 | |
189 | ;; Populate /dev. | |
150e20dd | 190 | (make-essential-device-nodes #:root target-directory) |
55651ff2 LC |
191 | |
192 | ;; Optionally, register the inputs in the image's store. | |
150e20dd LC |
193 | (when register-closures? |
194 | (unless copy-closures? | |
195 | ;; XXX: 'guix-register' wants to palpate the things it registers, so | |
196 | ;; bind-mount the store on the target. | |
197 | (mkdir-p target-store) | |
198 | (mount (%store-directory) target-store "" MS_BIND)) | |
199 | ||
200 | (display "registering closures...\n") | |
55651ff2 | 201 | (for-each (lambda (closure) |
150e20dd LC |
202 | (register-closure target-directory |
203 | (string-append "/xchg/" closure))) | |
204 | closures) | |
205 | (unless copy-closures? | |
206 | (system* "umount" target-store))) | |
55651ff2 | 207 | |
641f9a2a | 208 | ;; Add the non-store directories and files. |
150e20dd | 209 | (display "populating...\n") |
f2c403ea | 210 | (populate-root-file-system system-directory target-directory)) |
641f9a2a LC |
211 | |
212 | (define* (initialize-hard-disk device | |
213 | #:key | |
f2c403ea | 214 | system-directory |
641f9a2a LC |
215 | grub.cfg |
216 | disk-image-size | |
217 | (file-system-type "ext4") | |
ef9fc40d | 218 | file-system-label |
641f9a2a LC |
219 | (closures '()) |
220 | copy-closures? | |
221 | (register-closures? #t)) | |
ef9fc40d LC |
222 | "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a FILE-SYSTEM-TYPE |
223 | partition with (optionally) FILE-SYSTEM-LABEL as its volume name, and with | |
224 | GRUB installed. If REGISTER-CLOSURES? is true, register all of CLOSURES is | |
225 | the partition's store. If COPY-CLOSURES? is true, copy all of CLOSURES to the | |
f2c403ea LC |
226 | partition. SYSTEM-DIRECTORY is the name of the directory of the 'system' |
227 | derivation." | |
641f9a2a LC |
228 | (define target-directory |
229 | "/fs") | |
230 | ||
231 | (define partition | |
232 | (string-append device "1")) | |
233 | ||
234 | (initialize-partition-table device | |
235 | (- disk-image-size (* 5 (expt 2 20)))) | |
236 | ||
ef9fc40d LC |
237 | (format-partition partition file-system-type |
238 | #:label file-system-label) | |
641f9a2a LC |
239 | |
240 | (display "mounting partition...\n") | |
241 | (mkdir target-directory) | |
242 | (mount partition target-directory file-system-type) | |
243 | ||
244 | (initialize-root-partition target-directory | |
f2c403ea | 245 | #:system-directory system-directory |
641f9a2a LC |
246 | #:copy-closures? copy-closures? |
247 | #:register-closures? register-closures? | |
248 | #:closures closures) | |
55651ff2 | 249 | |
641f9a2a | 250 | (install-grub grub.cfg device target-directory) |
55651ff2 | 251 | |
15d29987 LC |
252 | ;; 'guix-register' resets timestamps and everything, so no need to do it |
253 | ;; once more in that case. | |
254 | (unless register-closures? | |
255 | (reset-timestamps target-directory)) | |
55651ff2 | 256 | |
150e20dd | 257 | (zero? (system* "umount" target-directory))) |
55651ff2 | 258 | |
e1a87b90 | 259 | ;;; vm.scm ends here |