1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
19 (define-module (gnu system vm)
20 #:use-module (guix config)
21 #:use-module (guix store)
22 #:use-module (guix derivations)
23 #:use-module (guix packages)
24 #:use-module (guix monads)
25 #:use-module ((gnu packages base)
26 #:select (%final-inputs
27 guile-final gcc-final glibc-final
28 ld-wrapper binutils-final
29 coreutils findutils grep sed tzdata))
30 #:use-module (gnu packages guile)
31 #:use-module (gnu packages bash)
32 #:use-module (gnu packages less)
33 #:use-module (gnu packages qemu)
34 #:use-module (gnu packages parted)
35 #:use-module (gnu packages zile)
36 #:use-module (gnu packages grub)
37 #:use-module (gnu packages linux)
38 #:use-module (gnu packages package-management)
39 #:use-module ((gnu packages make-bootstrap)
40 #:select (%guile-static-stripped))
41 #:use-module (gnu packages admin)
43 #:use-module (gnu system shadow)
44 #:use-module (gnu system linux)
45 #:use-module (gnu system linux-initrd)
46 #:use-module (gnu system grub)
47 #:use-module (gnu system)
48 #:use-module (gnu services)
50 #:use-module (srfi srfi-1)
51 #:use-module (srfi srfi-26)
52 #:use-module (ice-9 match)
54 #:export (expression->derivation-in-linux-vm
57 system-qemu-image/shared-store
58 system-qemu-image/shared-store-script))
63 ;;; Tools to evaluate build expressions within virtual machines.
67 (define* (expression->derivation-in-linux-vm name exp
69 (system (%current-system))
73 (qemu qemu/smb-shares)
80 (references-graphs #f)
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.
88 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
89 DISK-IMAGE-SIZE bytes and return it.
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."
94 ;; FIXME: Allow use of macros from other modules, as done in
95 ;; `build-expression->derivation'.
98 (with-monad %store-monad
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
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))))
117 ;; Code that launches the VM that evaluates EXP.
119 (use-modules (guix build utils)
123 (let ((out (assoc-ref %outputs "out"))
124 (cu (string-append (assoc-ref %build-inputs "coreutils")
126 (qemu (string-append (assoc-ref %build-inputs "qemu")
128 (car (string-split ,system #\-))))
129 (img (string-append (assoc-ref %build-inputs "qemu")
131 (linux (string-append (assoc-ref %build-inputs "linux")
133 (initrd (string-append (assoc-ref %build-inputs "initrd")
135 (builder (assoc-ref %build-inputs "builder")))
137 ;; XXX: QEMU uses "rm -rf" when it's done to remove the temporary SMB
138 ;; directory, so it really needs `rm' in $PATH.
141 ,(if make-disk-image?
142 `(zero? (system* img "create" "-f" "qcow2" "image.qcow2"
143 ,(number->string disk-image-size)))
148 ;; Copy the reference-graph files under xchg/ so EXP can access it.
150 ,@(match references-graphs
151 (((graph-files . _) ...)
154 ,(string-append "xchg/" file)))
159 (system* qemu "-enable-kvm" "-nographic" "-no-reboot"
160 "-net" "nic,model=e1000"
161 "-net" (string-append "user,smb=" (getcwd))
164 "-append" (string-append "console=ttyS0 --load="
166 ,@(if make-disk-image?
167 '("-hda" "image.qcow2")
169 ,(if make-disk-image?
170 '(copy-file "image.qcow2" ; XXX: who mkdir'd OUT?
174 (copy-recursively "xchg" out)))))))
177 ((input-alist (sequence %store-monad input-alist))
178 (exp* -> `(let ((%build-inputs ',input-alist))
180 (user-builder (text-file "builder-in-linux-vm"
181 (object->string exp*)))
182 (coreutils -> (car (assoc-ref %final-inputs "coreutils")))
183 (initrd (if initrd ; use the default initrd?
185 (qemu-initrd #:guile-modules-in-chroot? #t)))
186 (inputs (lower-inputs `(("qemu" ,qemu)
189 ("coreutils" ,coreutils)
190 ("builder" ,user-builder)
192 (derivation-expression name builder
193 ;; TODO: Require the "kvm" feature.
197 #:modules (delete-duplicates
200 #:guile-for-build guile-for-build
201 #:references-graphs references-graphs)))
203 (define* (qemu-image #:key
205 (system (%current-system))
206 (disk-image-size (* 100 (expt 2 20)))
208 (initialize-store? #f)
211 (inputs-to-copy '()))
212 "Return a bootable, stand-alone QEMU image. The returned image is a full
213 disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
214 configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.)
216 INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
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.
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,
224 (define (input->name+derivation tuple)
225 (with-monad %store-monad
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))))))
241 ((graph (sequence %store-monad
242 (map input->name+derivation inputs-to-copy))))
243 (expression->derivation-in-linux-vm
246 (use-modules (ice-9 rdelim)
249 (guix build linux-initrd))
251 (let ((parted (string-append (assoc-ref %build-inputs "parted")
253 (mkfs (string-append (assoc-ref %build-inputs "e2fsprogs")
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
259 (grub.cfg ,grub-configuration))
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))
266 (cond ((eof-object? line)
267 (delete-duplicates result))
268 ((string-prefix? "/" line)
269 (loop (read-line port)
272 (loop (read-line port)
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))
281 ,(match inputs-to-copy
282 (((graph-files . _) ...)
283 `(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
285 (paths (append-map graph-from-file graph-files)))
286 (delete-duplicates paths)))
289 ;; GRUB is full of shell scripts.
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"))
298 (display "creating partition table...\n")
299 (and (zero? (system* parted "/dev/sda" "mklabel" "msdos"
300 "mkpart" "primary" "ext2" "1MiB"
303 (* 5 (expt 2 20))))))
305 (display "creating ext3 partition...\n")
306 (and (zero? (system* mkfs "-F" "/dev/sda1"))
307 (let ((store (string-append "/fs" ,%store-directory)))
308 (display "mounting partition...\n")
310 (mount "/dev/sda1" "/fs" "ext3")
311 (mkdir-p "/fs/boot/grub")
312 (symlink grub.cfg "/fs/boot/grub/grub.cfg")
314 ;; Populate the image's store.
317 (for-each (lambda (thing)
318 (copy-recursively thing
324 (make-essential-device-nodes #:root "/fs")
326 ;; Optionally, register the inputs in the image's store.
327 (let* ((guix (assoc-ref %build-inputs "guix"))
330 "/sbin/guix-register"))))
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/"
341 ;; Evaluate the POPULATE directives.
342 ,@(let loop ((directives populate)
346 (reverse statements))
347 ((('directory name) rest ...)
349 (cons `(mkdir-p ,(string-append "/fs" name))
351 ((('directory name uid gid) rest ...)
352 (let ((dir (string-append "/fs" name)))
354 (cons* `(chown ,dir ,uid ,gid)
357 (((new '-> old) rest ...)
360 ,(string-append "/fs" new))
363 (and=> (assoc-ref %build-inputs "populate")
366 (primitive-load populate)
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 ;; /gnu/store, which is the host,
378 (unless (eq? (stat:type s) 'symlink)
379 (utime file 0 0 0 0))))
380 (find-files "/fs" ".*"))
383 (system* grub "--no-floppy"
384 "--boot-directory" "/fs/boot"
387 (when (file-exists? "/fs/dev/pts")
388 ;; Unmount devpts so /fs itself can be
389 ;; unmounted (failing to do that leads to
391 (system* umount "/fs/dev/pts"))
392 (zero? (system* umount "/fs")))
395 #:inputs `(("parted" ,parted)
397 ("e2fsprogs" ,e2fsprogs)
399 ;; For shell scripts.
400 ("sed" ,(car (assoc-ref %final-inputs "sed")))
401 ("grep" ,(car (assoc-ref %final-inputs "grep")))
402 ("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
403 ("findutils" ,(car (assoc-ref %final-inputs "findutils")))
404 ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
405 ("util-linux" ,util-linux)
407 ,@(if initialize-store?
412 #:make-disk-image? #t
413 #:disk-image-size disk-image-size
414 #:references-graphs graph
415 #:modules '((guix build utils)
416 (guix build linux-initrd)))))
420 ;;; Stand-alone VM image.
423 (define (operating-system-build-gid os)
424 "Return as a monadic value the group id for build users of OS, or #f."
427 (and (equal? '(guix-daemon)
428 (service-provision service))
429 (match (service-user-groups service)
431 (user-group-id group)))))
432 (operating-system-services os)))
434 (define (operating-system-default-contents os)
435 "Return a list of directives suitable for 'system-qemu-image' describing the
436 basic contents of the root file system of OS."
437 (define (user-directories user)
438 (let ((home (user-account-home-directory user))
439 ;; XXX: Deal with automatically allocated ids.
440 (uid (or (user-account-uid user) 0))
441 (gid (or (user-account-gid user) 0))
442 (root (string-append "/var/nix/profiles/per-user/"
443 (user-account-name user))))
444 `((directory ,root ,uid ,gid)
445 (directory ,home ,uid ,gid))))
447 (mlet* %store-monad ((os-drv (operating-system-derivation os))
448 (os-dir -> (derivation->output-path os-drv))
449 (build-gid (operating-system-build-gid os))
450 (profile (operating-system-profile-directory os)))
451 (return `((directory ,(%store-prefix) 0 ,(or build-gid 0))
453 (directory "/var/log") ; for dmd
454 (directory "/var/run/nscd")
455 (directory "/var/nix/gcroots")
456 ("/var/nix/gcroots/system" -> ,os-dir)
458 ("/run/current-system" -> ,profile)
460 ("/bin/sh" -> "/run/current-system/bin/bash")
462 (directory "/var/nix/profiles/per-user/root" 0 0)
464 (directory "/root" 0 0) ; an exception
465 ,@(append-map user-directories
466 (operating-system-users os))))))
468 (define* (system-qemu-image os
469 #:key (disk-image-size (* 900 (expt 2 20))))
470 "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU
471 system as described by OS."
473 ((os-drv (operating-system-derivation os))
474 (os-dir -> (derivation->output-path os-drv))
475 (grub.cfg -> (string-append os-dir "/grub.cfg"))
476 (populate (operating-system-default-contents os)))
477 (qemu-image #:grub-configuration grub.cfg
479 #:disk-image-size disk-image-size
480 #:initialize-store? #t
481 #:inputs-to-copy `(("system" ,os-drv)))))
483 (define* (system-qemu-image/shared-store
485 #:key (disk-image-size (* 15 (expt 2 20))))
486 "Return a derivation that builds a QEMU image of OS that shares its store
489 ((os-drv (operating-system-derivation os))
490 (os-dir -> (derivation->output-path os-drv))
491 (grub.cfg -> (string-append os-dir "/grub.cfg"))
492 (populate (operating-system-default-contents os)))
493 ;; TODO: Initialize the database so Guix can be used in the guest.
494 (qemu-image #:grub-configuration grub.cfg
496 #:disk-image-size disk-image-size)))
498 (define* (system-qemu-image/shared-store-script
501 (qemu (package (inherit qemu)
502 ;; FIXME/TODO: Use 9p instead of this hack.
503 (source (package-source qemu/smb-shares))))
505 "Return a derivation that builds a script to run a virtual machine image of
506 OS that shares its store with the host."
507 (let* ((initrd (qemu-initrd #:mounts `((cifs "/store" ,(%store-prefix)))
508 #:volatile-root? #t))
509 (os (operating-system (inherit os) (initrd initrd))))
511 (mlet %store-monad ((image (system-qemu-image/shared-store os))
512 (qemu (package-file qemu
513 "bin/qemu-system-x86_64"))
514 (bash (package-file bash "bin/sh"))
515 (kernel (package-file (operating-system-kernel os)
518 (os-drv (operating-system-derivation os)))
519 (return `(let ((out (assoc-ref %outputs "out")))
520 (call-with-output-file out
523 (string-append "#!" ,bash "
524 # TODO: -virtfs local,path=XXX,security_model=none,mount_tag=store
525 exec " ,qemu " -enable-kvm -no-reboot -net nic,model=virtio \
527 -kernel " ,kernel " -initrd "
528 ,(string-append (derivation->output-path initrd) "/initrd") " \
529 -append \"" ,(if graphic? "" "console=ttyS0 ")
530 "--load=" ,(derivation->output-path os-drv) "/boot --root=/dev/vda1\" \
531 -drive file=" ,(derivation->output-path image)
532 ",if=virtio,cache=writeback,werror=report,readonly\n")
537 (mlet %store-monad ((image (system-qemu-image/shared-store os))
539 (qemu (package->derivation qemu))
540 (bash (package->derivation bash))
541 (os (operating-system-derivation os))
543 (derivation-expression "run-vm.sh" builder
544 #:inputs `(("qemu" ,qemu)