Commit | Line | Data |
---|---|---|
04086015 | 1 | ;;; GNU Guix --- Functional package management for GNU |
735c6dd7 | 2 | ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> |
04086015 LC |
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 | ||
19 | (define-module (gnu system vm) | |
93d44bd8 | 20 | #:use-module (guix config) |
04086015 LC |
21 | #:use-module (guix store) |
22 | #:use-module (guix derivations) | |
23 | #:use-module (guix packages) | |
d9f0a237 | 24 | #:use-module (guix monads) |
9f84f12f LC |
25 | #:use-module ((gnu packages base) |
26 | #:select (%final-inputs | |
27 | guile-final gcc-final glibc-final | |
4f62d8d6 | 28 | ld-wrapper binutils-final |
3141a8bd | 29 | coreutils findutils grep sed tzdata)) |
1b89a66e LC |
30 | #:use-module (gnu packages guile) |
31 | #:use-module (gnu packages bash) | |
4f62d8d6 | 32 | #:use-module (gnu packages less) |
04086015 LC |
33 | #:use-module (gnu packages qemu) |
34 | #:use-module (gnu packages parted) | |
5b16ff09 | 35 | #:use-module (gnu packages zile) |
04086015 LC |
36 | #:use-module (gnu packages grub) |
37 | #:use-module (gnu packages linux) | |
30f25b03 | 38 | #:use-module (gnu packages package-management) |
04086015 LC |
39 | #:use-module ((gnu packages make-bootstrap) |
40 | #:select (%guile-static-stripped)) | |
9de46ffb | 41 | #:use-module (gnu packages admin) |
0ded70f3 LC |
42 | |
43 | #:use-module (gnu system shadow) | |
44 | #:use-module (gnu system linux) | |
735c6dd7 | 45 | #:use-module (gnu system linux-initrd) |
0ded70f3 | 46 | #:use-module (gnu system grub) |
4646e30a | 47 | #:use-module (gnu system dmd) |
033adfe7 | 48 | #:use-module (gnu system) |
0ded70f3 | 49 | |
ca85d7bc | 50 | #:use-module (srfi srfi-1) |
04086015 LC |
51 | #:use-module (srfi srfi-26) |
52 | #:use-module (ice-9 match) | |
0ded70f3 | 53 | |
04086015 | 54 | #:export (expression->derivation-in-linux-vm |
aedb72fb | 55 | qemu-image |
fd3bfc44 LC |
56 | system-qemu-image |
57 | system-qemu-image/shared-store | |
58 | system-qemu-image/shared-store-script)) | |
04086015 LC |
59 | |
60 | \f | |
61 | ;;; Commentary: | |
62 | ;;; | |
63 | ;;; Tools to evaluate build expressions within virtual machines. | |
64 | ;;; | |
65 | ;;; Code: | |
66 | ||
d9f0a237 | 67 | (define* (expression->derivation-in-linux-vm name exp |
04086015 | 68 | #:key |
2455085a LC |
69 | (system (%current-system)) |
70 | (inputs '()) | |
04086015 | 71 | (linux linux-libre) |
735c6dd7 | 72 | initrd |
50731c51 | 73 | (qemu qemu/smb-shares) |
04086015 LC |
74 | (env-vars '()) |
75 | (modules '()) | |
76 | (guile-for-build | |
77 | (%guile-for-build)) | |
78 | ||
79 | (make-disk-image? #f) | |
ca85d7bc | 80 | (references-graphs #f) |
04086015 LC |
81 | (disk-image-size |
82 | (* 100 (expt 2 20)))) | |
735c6dd7 LC |
83 | "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a |
84 | derivation). In the virtual machine, EXP has access to all of INPUTS from the | |
85 | store; it should put its output files in the `/xchg' directory, which is | |
86 | copied to the derivation's output when the VM terminates. | |
04086015 LC |
87 | |
88 | When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of | |
ca85d7bc LC |
89 | DISK-IMAGE-SIZE bytes and return it. |
90 | ||
91 | When REFERENCES-GRAPHS is true, it must be a list of file name/store path | |
92 | pairs, as for `derivation'. The files containing the reference graphs are | |
93 | made available under the /xchg CIFS share." | |
8ab73e91 LC |
94 | ;; FIXME: Allow use of macros from other modules, as done in |
95 | ;; `build-expression->derivation'. | |
96 | ||
04086015 | 97 | (define input-alist |
d9f0a237 LC |
98 | (with-monad %store-monad |
99 | (map (match-lambda | |
100 | ((input (? package? package)) | |
101 | (mlet %store-monad ((out (package-file package #:system system))) | |
102 | (return `(,input . ,out)))) | |
103 | ((input (? package? package) sub-drv) | |
104 | (mlet %store-monad ((out (package-file package | |
105 | #:output sub-drv | |
106 | #:system system))) | |
107 | (return `(,input . ,out)))) | |
108 | ((input (? derivation? drv)) | |
109 | (return `(,input . ,(derivation->output-path drv)))) | |
110 | ((input (? derivation? drv) sub-drv) | |
111 | (return `(,input . ,(derivation->output-path drv sub-drv)))) | |
112 | ((input (and (? string?) (? store-path?) file)) | |
113 | (return `(,input . ,file)))) | |
114 | inputs))) | |
04086015 LC |
115 | |
116 | (define builder | |
117 | ;; Code that launches the VM that evaluates EXP. | |
ca85d7bc LC |
118 | `(let () |
119 | (use-modules (guix build utils) | |
120 | (srfi srfi-1) | |
121 | (ice-9 rdelim)) | |
04086015 LC |
122 | |
123 | (let ((out (assoc-ref %outputs "out")) | |
124 | (cu (string-append (assoc-ref %build-inputs "coreutils") | |
125 | "/bin")) | |
126 | (qemu (string-append (assoc-ref %build-inputs "qemu") | |
127 | "/bin/qemu-system-" | |
128 | (car (string-split ,system #\-)))) | |
129 | (img (string-append (assoc-ref %build-inputs "qemu") | |
130 | "/bin/qemu-img")) | |
131 | (linux (string-append (assoc-ref %build-inputs "linux") | |
132 | "/bzImage")) | |
133 | (initrd (string-append (assoc-ref %build-inputs "initrd") | |
134 | "/initrd")) | |
135 | (builder (assoc-ref %build-inputs "builder"))) | |
136 | ||
137 | ;; XXX: QEMU uses "rm -rf" when it's done to remove the temporary SMB | |
138 | ;; directory, so it really needs `rm' in $PATH. | |
139 | (setenv "PATH" cu) | |
140 | ||
141 | ,(if make-disk-image? | |
30e45750 | 142 | `(zero? (system* img "create" "-f" "qcow2" "image.qcow2" |
04086015 LC |
143 | ,(number->string disk-image-size))) |
144 | '(begin)) | |
145 | ||
146 | (mkdir "xchg") | |
ca85d7bc LC |
147 | |
148 | ;; Copy the reference-graph files under xchg/ so EXP can access it. | |
149 | (begin | |
150 | ,@(match references-graphs | |
151 | (((graph-files . _) ...) | |
152 | (map (lambda (file) | |
153 | `(copy-file ,file | |
154 | ,(string-append "xchg/" file))) | |
155 | graph-files)) | |
156 | (#f '()))) | |
157 | ||
04086015 | 158 | (and (zero? |
a7d46f12 | 159 | (system* qemu "-enable-kvm" "-nographic" "-no-reboot" |
04086015 LC |
160 | "-net" "nic,model=e1000" |
161 | "-net" (string-append "user,smb=" (getcwd)) | |
162 | "-kernel" linux | |
163 | "-initrd" initrd | |
164 | "-append" (string-append "console=ttyS0 --load=" | |
165 | builder) | |
166 | ,@(if make-disk-image? | |
167 | '("-hda" "image.qcow2") | |
168 | '()))) | |
169 | ,(if make-disk-image? | |
170 | '(copy-file "image.qcow2" ; XXX: who mkdir'd OUT? | |
171 | out) | |
172 | '(begin | |
173 | (mkdir out) | |
174 | (copy-recursively "xchg" out))))))) | |
175 | ||
d9f0a237 LC |
176 | (mlet* %store-monad |
177 | ((input-alist (sequence %store-monad input-alist)) | |
178 | (exp* -> `(let ((%build-inputs ',input-alist)) | |
179 | ,exp)) | |
180 | (user-builder (text-file "builder-in-linux-vm" | |
181 | (object->string exp*))) | |
182 | (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) | |
d4254711 | 183 | (initrd (if initrd ; use the default initrd? |
735c6dd7 | 184 | (return initrd) |
d4254711 | 185 | (qemu-initrd #:guile-modules-in-chroot? #t))) |
d9f0a237 LC |
186 | (inputs (lower-inputs `(("qemu" ,qemu) |
187 | ("linux" ,linux) | |
188 | ("initrd" ,initrd) | |
189 | ("coreutils" ,coreutils) | |
190 | ("builder" ,user-builder) | |
191 | ,@inputs)))) | |
dd1a5a15 | 192 | (derivation-expression name builder |
a7d46f12 | 193 | ;; TODO: Require the "kvm" feature. |
dd1a5a15 LC |
194 | #:system system |
195 | #:inputs inputs | |
d9f0a237 LC |
196 | #:env-vars env-vars |
197 | #:modules (delete-duplicates | |
198 | `((guix build utils) | |
199 | ,@modules)) | |
200 | #:guile-for-build guile-for-build | |
201 | #:references-graphs references-graphs))) | |
202 | ||
203 | (define* (qemu-image #:key | |
04086015 LC |
204 | (name "qemu-image") |
205 | (system (%current-system)) | |
206 | (disk-image-size (* 100 (expt 2 20))) | |
0e2ddecd | 207 | grub-configuration |
30f25b03 | 208 | (initialize-store? #f) |
785859d3 | 209 | (populate #f) |
93d44bd8 | 210 | (inputs '()) |
002e5ba8 | 211 | (inputs-to-copy '())) |
1b89a66e | 212 | "Return a bootable, stand-alone QEMU image. The returned image is a full |
0e2ddecd | 213 | disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its |
033adfe7 | 214 | configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.) |
93d44bd8 LC |
215 | |
216 | INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied | |
30f25b03 LC |
217 | into the image being built. When INITIALIZE-STORE? is true, initialize the |
218 | store database in the image so that Guix can be used in the image. | |
785859d3 | 219 | |
d5d0f286 LC |
220 | POPULATE is a list of directives stating directories or symlinks to be created |
221 | in the disk image partition. It is evaluated once the image has been | |
222 | populated with INPUTS-TO-COPY. It can be used to provide additional files, | |
223 | such as /etc files." | |
d9f0a237 LC |
224 | (define (input->name+derivation tuple) |
225 | (with-monad %store-monad | |
226 | (match tuple | |
227 | ((name (? package? package)) | |
228 | (mlet %store-monad ((drv (package->derivation package system))) | |
229 | (return `(,name . ,(derivation->output-path drv))))) | |
230 | ((name (? package? package) sub-drv) | |
231 | (mlet %store-monad ((drv (package->derivation package system))) | |
232 | (return `(,name . ,(derivation->output-path drv sub-drv))))) | |
233 | ((name (? derivation? drv)) | |
234 | (return `(,name . ,(derivation->output-path drv)))) | |
235 | ((name (? derivation? drv) sub-drv) | |
236 | (return `(,name . ,(derivation->output-path drv sub-drv)))) | |
237 | ((input (and (? string?) (? store-path?) file)) | |
238 | (return `(,input . ,file)))))) | |
239 | ||
240 | (mlet %store-monad | |
241 | ((graph (sequence %store-monad | |
242 | (map input->name+derivation inputs-to-copy)))) | |
243 | (expression->derivation-in-linux-vm | |
244 | "qemu-image" | |
245 | `(let () | |
246 | (use-modules (ice-9 rdelim) | |
247 | (srfi srfi-1) | |
248 | (guix build utils) | |
249 | (guix build linux-initrd)) | |
250 | ||
251 | (let ((parted (string-append (assoc-ref %build-inputs "parted") | |
252 | "/sbin/parted")) | |
253 | (mkfs (string-append (assoc-ref %build-inputs "e2fsprogs") | |
254 | "/sbin/mkfs.ext3")) | |
255 | (grub (string-append (assoc-ref %build-inputs "grub") | |
256 | "/sbin/grub-install")) | |
257 | (umount (string-append (assoc-ref %build-inputs "util-linux") | |
258 | "/bin/umount")) ; XXX: add to Guile | |
033adfe7 | 259 | (grub.cfg ,grub-configuration)) |
d9f0a237 LC |
260 | |
261 | (define (read-reference-graph port) | |
262 | ;; Return a list of store paths from the reference graph at PORT. | |
263 | ;; The data at PORT is the format produced by #:references-graphs. | |
264 | (let loop ((line (read-line port)) | |
265 | (result '())) | |
266 | (cond ((eof-object? line) | |
267 | (delete-duplicates result)) | |
268 | ((string-prefix? "/" line) | |
269 | (loop (read-line port) | |
270 | (cons line result))) | |
271 | (else | |
272 | (loop (read-line port) | |
273 | result))))) | |
274 | ||
275 | (define (things-to-copy) | |
276 | ;; Return the list of store files to copy to the image. | |
277 | (define (graph-from-file file) | |
278 | (call-with-input-file file | |
279 | read-reference-graph)) | |
280 | ||
281 | ,(match inputs-to-copy | |
282 | (((graph-files . _) ...) | |
283 | `(let* ((graph-files ',(map (cut string-append "/xchg/" <>) | |
284 | graph-files)) | |
285 | (paths (append-map graph-from-file graph-files))) | |
286 | (delete-duplicates paths))) | |
287 | (#f ''()))) | |
288 | ||
289 | ;; GRUB is full of shell scripts. | |
290 | (setenv "PATH" | |
291 | (string-append (dirname grub) ":" | |
292 | (assoc-ref %build-inputs "coreutils") "/bin:" | |
293 | (assoc-ref %build-inputs "findutils") "/bin:" | |
294 | (assoc-ref %build-inputs "sed") "/bin:" | |
295 | (assoc-ref %build-inputs "grep") "/bin:" | |
296 | (assoc-ref %build-inputs "gawk") "/bin")) | |
297 | ||
298 | (display "creating partition table...\n") | |
fc4bc4b6 | 299 | (and (zero? (system* parted "/dev/sda" "mklabel" "msdos" |
d9f0a237 LC |
300 | "mkpart" "primary" "ext2" "1MiB" |
301 | ,(format #f "~aB" | |
302 | (- disk-image-size | |
303 | (* 5 (expt 2 20)))))) | |
304 | (begin | |
305 | (display "creating ext3 partition...\n") | |
fc4bc4b6 | 306 | (and (zero? (system* mkfs "-F" "/dev/sda1")) |
d9f0a237 LC |
307 | (let ((store (string-append "/fs" ,%store-directory))) |
308 | (display "mounting partition...\n") | |
309 | (mkdir "/fs") | |
fc4bc4b6 | 310 | (mount "/dev/sda1" "/fs" "ext3") |
d9f0a237 LC |
311 | (mkdir-p "/fs/boot/grub") |
312 | (symlink grub.cfg "/fs/boot/grub/grub.cfg") | |
313 | ||
314 | ;; Populate the image's store. | |
315 | (mkdir-p store) | |
316 | (chmod store #o1775) | |
317 | (for-each (lambda (thing) | |
318 | (copy-recursively thing | |
319 | (string-append "/fs" | |
320 | thing))) | |
033adfe7 | 321 | (things-to-copy)) |
d9f0a237 LC |
322 | |
323 | ;; Populate /dev. | |
324 | (make-essential-device-nodes #:root "/fs") | |
325 | ||
326 | ;; Optionally, register the inputs in the image's store. | |
327 | (let* ((guix (assoc-ref %build-inputs "guix")) | |
fd3bfc44 LC |
328 | (register (and guix |
329 | (string-append guix | |
330 | "/sbin/guix-register")))) | |
d9f0a237 LC |
331 | ,@(if initialize-store? |
332 | (match inputs-to-copy | |
333 | (((graph-files . _) ...) | |
334 | (map (lambda (closure) | |
335 | `(system* register "--prefix" "/fs" | |
336 | ,(string-append "/xchg/" | |
337 | closure))) | |
338 | graph-files))) | |
339 | '(#f))) | |
340 | ||
341 | ;; Evaluate the POPULATE directives. | |
342 | ,@(let loop ((directives populate) | |
343 | (statements '())) | |
344 | (match directives | |
345 | (() | |
346 | (reverse statements)) | |
347 | ((('directory name) rest ...) | |
348 | (loop rest | |
349 | (cons `(mkdir-p ,(string-append "/fs" name)) | |
350 | statements))) | |
351 | ((('directory name uid gid) rest ...) | |
352 | (let ((dir (string-append "/fs" name))) | |
353 | (loop rest | |
354 | (cons* `(chown ,dir ,uid ,gid) | |
355 | `(mkdir-p ,dir) | |
356 | statements)))) | |
357 | (((new '-> old) rest ...) | |
358 | (loop rest | |
359 | (cons `(symlink ,old | |
360 | ,(string-append "/fs" new)) | |
361 | statements))))) | |
362 | ||
363 | (and=> (assoc-ref %build-inputs "populate") | |
364 | (lambda (populate) | |
365 | (chdir "/fs") | |
366 | (primitive-load populate) | |
367 | (chdir "/"))) | |
368 | ||
369 | (display "clearing file timestamps...\n") | |
370 | (for-each (lambda (file) | |
371 | (let ((s (lstat file))) | |
372 | ;; XXX: Guile uses libc's 'utime' function | |
373 | ;; (not 'futime'), so the timestamp of | |
374 | ;; symlinks cannot be changed, and there | |
375 | ;; are symlinks here pointing to | |
376 | ;; /nix/store, which is the host, | |
377 | ;; read-only store. | |
378 | (unless (eq? (stat:type s) 'symlink) | |
379 | (utime file 0 0 0 0)))) | |
380 | (find-files "/fs" ".*")) | |
381 | ||
382 | (and (zero? | |
383 | (system* grub "--no-floppy" | |
384 | "--boot-directory" "/fs/boot" | |
fc4bc4b6 | 385 | "/dev/sda")) |
d9f0a237 LC |
386 | (zero? (system* umount "/fs")) |
387 | (reboot)))))))) | |
388 | #:system system | |
389 | #:inputs `(("parted" ,parted) | |
390 | ("grub" ,grub) | |
391 | ("e2fsprogs" ,e2fsprogs) | |
d9f0a237 LC |
392 | |
393 | ;; For shell scripts. | |
394 | ("sed" ,(car (assoc-ref %final-inputs "sed"))) | |
395 | ("grep" ,(car (assoc-ref %final-inputs "grep"))) | |
396 | ("coreutils" ,(car (assoc-ref %final-inputs "coreutils"))) | |
397 | ("findutils" ,(car (assoc-ref %final-inputs "findutils"))) | |
398 | ("gawk" ,(car (assoc-ref %final-inputs "gawk"))) | |
399 | ("util-linux" ,util-linux) | |
400 | ||
401 | ,@(if initialize-store? | |
402 | `(("guix" ,guix)) | |
403 | '()) | |
404 | ||
405 | ,@inputs-to-copy) | |
406 | #:make-disk-image? #t | |
407 | #:disk-image-size disk-image-size | |
408 | #:references-graphs graph | |
409 | #:modules '((guix build utils) | |
410 | (guix build linux-initrd))))) | |
04086015 LC |
411 | |
412 | \f | |
413 | ;;; | |
aedb72fb | 414 | ;;; Stand-alone VM image. |
04086015 LC |
415 | ;;; |
416 | ||
033adfe7 LC |
417 | (define %demo-operating-system |
418 | (operating-system | |
419 | (host-name "gnu") | |
420 | (timezone "Europe/Paris") | |
3141a8bd | 421 | (locale "en_US.UTF-8") |
033adfe7 LC |
422 | (users (list (user-account |
423 | (name "guest") | |
424 | (password "") | |
425 | (uid 1000) (gid 100) | |
426 | (comment "Guest of GNU") | |
78ed0038 | 427 | (home-directory "/home/guest")))) |
4f62d8d6 LC |
428 | (packages (list coreutils |
429 | bash | |
430 | guile-2.0 | |
431 | dmd | |
432 | gcc-final | |
433 | ld-wrapper ; must come before BINUTILS | |
434 | binutils-final | |
435 | glibc-final | |
436 | inetutils | |
437 | findutils | |
438 | grep | |
439 | sed | |
440 | procps | |
441 | psmisc | |
442 | zile | |
443 | less | |
3141a8bd | 444 | tzdata |
4f62d8d6 | 445 | guix)))) |
033adfe7 | 446 | |
fd3bfc44 LC |
447 | (define (operating-system-build-gid os) |
448 | "Return as a monadic value the group id for build users of OS, or #f." | |
449 | (anym %store-monad | |
450 | (lambda (service) | |
451 | (and (equal? '(guix-daemon) | |
452 | (service-provision service)) | |
453 | (match (service-user-groups service) | |
454 | ((group) | |
455 | (user-group-id group))))) | |
456 | (operating-system-services os))) | |
457 | ||
458 | (define (operating-system-default-contents os) | |
459 | "Return a list of directives suitable for 'system-qemu-image' describing the | |
460 | basic contents of the root file system of OS." | |
461 | (mlet* %store-monad ((os-drv (operating-system-derivation os)) | |
462 | (os-dir -> (derivation->output-path os-drv)) | |
463 | (build-user-gid (operating-system-build-gid os))) | |
464 | (return `((directory "/nix/store" 0 ,(or build-user-gid 0)) | |
465 | (directory "/etc") | |
466 | (directory "/var/log") ; for dmd | |
467 | (directory "/var/run/nscd") | |
468 | (directory "/var/nix/gcroots") | |
469 | ("/var/nix/gcroots/system" -> ,os-dir) | |
470 | (directory "/tmp") | |
471 | (directory "/var/nix/profiles/per-user/root" 0 0) | |
472 | (directory "/var/nix/profiles/per-user/guest" | |
473 | 1000 100) | |
474 | (directory "/home/guest" 1000 100))))) | |
475 | ||
22dd0438 LC |
476 | (define* (system-qemu-image #:optional (os %demo-operating-system) |
477 | #:key (disk-image-size (* 900 (expt 2 20)))) | |
478 | "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU | |
479 | system as described by OS." | |
0b8a376b | 480 | (mlet* %store-monad |
033adfe7 LC |
481 | ((os-drv (operating-system-derivation os)) |
482 | (os-dir -> (derivation->output-path os-drv)) | |
483 | (grub.cfg -> (string-append os-dir "/grub.cfg")) | |
fd3bfc44 | 484 | (populate (operating-system-default-contents os))) |
d9f0a237 LC |
485 | (qemu-image #:grub-configuration grub.cfg |
486 | #:populate populate | |
22dd0438 | 487 | #:disk-image-size disk-image-size |
d9f0a237 | 488 | #:initialize-store? #t |
033adfe7 | 489 | #:inputs-to-copy `(("system" ,os-drv))))) |
04086015 | 490 | |
fd3bfc44 LC |
491 | (define* (system-qemu-image/shared-store |
492 | #:optional (os %demo-operating-system) | |
493 | #:key (disk-image-size (* 15 (expt 2 20)))) | |
494 | "Return a derivation that builds a QEMU image of OS that shares its store | |
495 | with the host." | |
496 | (mlet* %store-monad | |
497 | ((os-drv (operating-system-derivation os)) | |
498 | (os-dir -> (derivation->output-path os-drv)) | |
499 | (grub.cfg -> (string-append os-dir "/grub.cfg")) | |
500 | (populate (operating-system-default-contents os))) | |
501 | ;; TODO: Initialize the database so Guix can be used in the guest. | |
502 | (qemu-image #:grub-configuration grub.cfg | |
503 | #:populate populate | |
504 | #:disk-image-size disk-image-size))) | |
505 | ||
506 | (define* (system-qemu-image/shared-store-script | |
507 | #:optional (os %demo-operating-system) | |
508 | #:key | |
509 | (qemu (package (inherit qemu) | |
510 | ;; FIXME/TODO: Use 9p instead of this hack. | |
511 | (source (package-source qemu/smb-shares)))) | |
512 | (graphic? #t)) | |
513 | "Return a derivation that builds a script to run a virtual machine image of | |
514 | OS that shares its store with the host." | |
515 | (let* ((initrd (qemu-initrd #:mounts `((cifs "/store" ,(%store-prefix))) | |
516 | #:volatile-root? #t)) | |
517 | (os (operating-system (inherit os) (initrd initrd)))) | |
518 | (define builder | |
519 | (mlet %store-monad ((image (system-qemu-image/shared-store os)) | |
520 | (qemu (package-file qemu | |
521 | "bin/qemu-system-x86_64")) | |
522 | (bash (package-file bash "bin/sh")) | |
523 | (kernel (package-file (operating-system-kernel os) | |
524 | "bzImage")) | |
525 | (initrd initrd) | |
526 | (os-drv (operating-system-derivation os))) | |
527 | (return `(let ((out (assoc-ref %outputs "out"))) | |
528 | (call-with-output-file out | |
529 | (lambda (port) | |
530 | (display | |
531 | (string-append "#!" ,bash " | |
532 | # TODO: -virtfs local,path=XXX,security_model=none,mount_tag=store | |
533 | exec " ,qemu " -enable-kvm -no-reboot -net nic,model=virtio \ | |
534 | -net user,smb=$PWD \ | |
535 | -kernel " ,kernel " -initrd " | |
536 | ,(string-append (derivation->output-path initrd) "/initrd") " \ | |
537 | -append \"" ,(if graphic? "" "console=ttyS0 ") | |
538 | "--load=" ,(derivation->output-path os-drv) "/boot --root=/dev/vda1\" \ | |
539 | -drive file=" ,(derivation->output-path image) | |
540 | ",if=virtio,cache=writeback,werror=report,readonly\n") | |
541 | port))) | |
542 | (chmod out #o555) | |
543 | #t)))) | |
544 | ||
545 | (mlet %store-monad ((image (system-qemu-image/shared-store os)) | |
546 | (initrd initrd) | |
547 | (qemu (package->derivation qemu)) | |
548 | (bash (package->derivation bash)) | |
549 | (os (operating-system-derivation os)) | |
550 | (builder builder)) | |
551 | (derivation-expression "run-vm.sh" builder | |
552 | #:inputs `(("qemu" ,qemu) | |
553 | ("image" ,image) | |
554 | ("bash" ,bash) | |
555 | ("initrd" ,initrd) | |
556 | ("os" ,os)))))) | |
557 | ||
04086015 | 558 | ;;; vm.scm ends here |