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