1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013 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 ((gnu packages base) #:select (%final-inputs
29 #:use-module (gnu packages guile)
30 #:use-module (gnu packages bash)
31 #:use-module (gnu packages qemu)
32 #:use-module (gnu packages parted)
33 #:use-module (gnu packages grub)
34 #:use-module (gnu packages linux)
35 #:use-module (gnu packages linux-initrd)
36 #:use-module (gnu packages package-management)
37 #:use-module ((gnu packages make-bootstrap)
38 #:select (%guile-static-stripped))
39 #:use-module (gnu packages system)
41 #:use-module (gnu system shadow)
42 #:use-module (gnu system linux)
43 #:use-module (gnu system grub)
44 #:use-module (gnu system dmd)
46 #:use-module (srfi srfi-1)
47 #:use-module (srfi srfi-26)
48 #:use-module (ice-9 match)
50 #:export (expression->derivation-in-linux-vm
57 ;;; Tools to evaluate build expressions within virtual machines.
61 (define* (expression->derivation-in-linux-vm store name exp
63 (system (%current-system))
67 (qemu qemu/smb-shares)
74 (references-graphs #f)
77 "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD. In the
78 virtual machine, EXP has access to all of INPUTS from the store; it should put
79 its output files in the `/xchg' directory, which is copied to the derivation's
80 output when the VM terminates.
82 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
83 DISK-IMAGE-SIZE bytes and return it.
85 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
86 pairs, as for `derivation'. The files containing the reference graphs are
87 made available under the /xchg CIFS share."
88 ;; FIXME: Allow use of macros from other modules, as done in
89 ;; `build-expression->derivation'.
93 ((input (? package? package))
94 `(,input . ,(package-output store package "out" system)))
95 ((input (? package? package) sub-drv)
96 `(,input . ,(package-output store package sub-drv system)))
97 ((input (? derivation? drv))
98 `(,input . ,(derivation->output-path drv)))
99 ((input (? derivation? drv) sub-drv)
100 `(,input . ,(derivation->output-path drv sub-drv)))
101 ((input (and (? string?) (? store-path?) file))
106 ;; EXP, but with INPUTS available.
107 `(let ((%build-inputs ',input-alist))
111 ;; Code that launches the VM that evaluates EXP.
113 (use-modules (guix build utils)
117 (let ((out (assoc-ref %outputs "out"))
118 (cu (string-append (assoc-ref %build-inputs "coreutils")
120 (qemu (string-append (assoc-ref %build-inputs "qemu")
122 (car (string-split ,system #\-))))
123 (img (string-append (assoc-ref %build-inputs "qemu")
125 (linux (string-append (assoc-ref %build-inputs "linux")
127 (initrd (string-append (assoc-ref %build-inputs "initrd")
129 (builder (assoc-ref %build-inputs "builder")))
131 ;; XXX: QEMU uses "rm -rf" when it's done to remove the temporary SMB
132 ;; directory, so it really needs `rm' in $PATH.
135 ,(if make-disk-image?
136 `(zero? (system* img "create" "image.qcow2"
137 ,(number->string disk-image-size)))
142 ;; Copy the reference-graph files under xchg/ so EXP can access it.
144 ,@(match references-graphs
145 (((graph-files . _) ...)
148 ,(string-append "xchg/" file)))
153 (system* qemu "-nographic" "-no-reboot"
154 "-net" "nic,model=e1000"
155 "-net" (string-append "user,smb=" (getcwd))
158 "-append" (string-append "console=ttyS0 --load="
160 ,@(if make-disk-image?
161 '("-hda" "image.qcow2")
163 ,(if make-disk-image?
164 '(copy-file "image.qcow2" ; XXX: who mkdir'd OUT?
168 (copy-recursively "xchg" out)))))))
170 (let ((user-builder (add-text-to-store store "builder-in-linux-vm"
171 (object->string exp*)
173 (->drv (cut package-derivation store <> system))
174 (coreutils (car (assoc-ref %final-inputs "coreutils"))))
175 (build-expression->derivation store name system builder
176 `(("qemu" ,(->drv qemu))
177 ("linux" ,(->drv linux))
178 ("initrd" ,(->drv initrd))
179 ("coreutils" ,(->drv coreutils))
180 ("builder" ,user-builder)
182 ((name (? package? package)
184 `(,name ,(->drv package)
186 ((name (? string? file))
191 #:modules (delete-duplicates
194 #:guile-for-build guile-for-build
195 #:references-graphs references-graphs)))
197 (define* (qemu-image store #:key
199 (system (%current-system))
200 (disk-image-size (* 100 (expt 2 20)))
202 (initialize-store? #f)
205 (inputs-to-copy '()))
206 "Return a bootable, stand-alone QEMU image. The returned image is a full
207 disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
210 INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
211 into the image being built. When INITIALIZE-STORE? is true, initialize the
212 store database in the image so that Guix can be used in the image.
214 POPULATE is a list of directives stating directories or symlinks to be created
215 in the disk image partition. It is evaluated once the image has been
216 populated with INPUTS-TO-COPY. It can be used to provide additional files,
218 (define input->name+derivation
220 ((name (? package? package))
221 `(,name . ,(derivation->output-path
222 (package-derivation store package system))))
223 ((name (? package? package) sub-drv)
224 `(,name . ,(derivation->output-path
225 (package-derivation store package system)
227 ((name (? derivation? drv))
228 `(,name . ,(derivation->output-path drv)))
229 ((name (? derivation? drv) sub-drv)
230 `(,name . ,(derivation->output-path drv sub-drv)))
231 ((input (and (? string?) (? store-path?) file))
234 (expression->derivation-in-linux-vm
237 (use-modules (ice-9 rdelim)
240 (guix build linux-initrd))
242 (let ((parted (string-append (assoc-ref %build-inputs "parted")
244 (mkfs (string-append (assoc-ref %build-inputs "e2fsprogs")
246 (grub (string-append (assoc-ref %build-inputs "grub")
247 "/sbin/grub-install"))
248 (umount (string-append (assoc-ref %build-inputs "util-linux")
249 "/bin/umount")) ; XXX: add to Guile
250 (grub.cfg (assoc-ref %build-inputs "grub.cfg")))
252 (define (read-reference-graph port)
253 ;; Return a list of store paths from the reference graph at PORT.
254 ;; The data at PORT is the format produced by #:references-graphs.
255 (let loop ((line (read-line port))
257 (cond ((eof-object? line)
258 (delete-duplicates result))
259 ((string-prefix? "/" line)
260 (loop (read-line port)
263 (loop (read-line port)
266 (define (things-to-copy)
267 ;; Return the list of store files to copy to the image.
268 (define (graph-from-file file)
269 (call-with-input-file file
270 read-reference-graph))
272 ,(match inputs-to-copy
273 (((graph-files . _) ...)
274 `(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
276 (paths (append-map graph-from-file graph-files)))
277 (delete-duplicates paths)))
280 ;; GRUB is full of shell scripts.
282 (string-append (dirname grub) ":"
283 (assoc-ref %build-inputs "coreutils") "/bin:"
284 (assoc-ref %build-inputs "findutils") "/bin:"
285 (assoc-ref %build-inputs "sed") "/bin:"
286 (assoc-ref %build-inputs "grep") "/bin:"
287 (assoc-ref %build-inputs "gawk") "/bin"))
289 (display "creating partition table...\n")
290 (and (zero? (system* parted "/dev/vda" "mklabel" "msdos"
291 "mkpart" "primary" "ext2" "1MiB"
294 (* 5 (expt 2 20))))))
296 (display "creating ext3 partition...\n")
297 (and (zero? (system* mkfs "-F" "/dev/vda1"))
299 (display "mounting partition...\n")
301 (mount "/dev/vda1" "/fs" "ext3")
302 (mkdir-p "/fs/boot/grub")
303 (symlink grub.cfg "/fs/boot/grub/grub.cfg")
305 ;; Populate the image's store.
306 (mkdir-p (string-append "/fs" ,%store-directory))
307 (for-each (lambda (thing)
308 (copy-recursively thing
311 (cons grub.cfg (things-to-copy)))
314 (make-essential-device-nodes #:root "/fs")
316 ;; Optionally, register the inputs in the image's store.
317 (let* ((guix (assoc-ref %build-inputs "guix"))
318 (register (string-append guix
319 "/sbin/guix-register")))
320 ,@(if initialize-store?
321 (match inputs-to-copy
322 (((graph-files . _) ...)
323 (map (lambda (closure)
324 `(system* register "--prefix" "/fs"
325 ,(string-append "/xchg/"
330 ;; Evaluate the POPULATE directives.
331 ,@(let loop ((directives populate)
335 (reverse statements))
336 ((('directory name) rest ...)
338 (cons `(mkdir-p ,(string-append "/fs" name))
340 (((new '-> old) rest ...)
343 ,(string-append "/fs" new))
346 (and=> (assoc-ref %build-inputs "populate")
349 (primitive-load populate)
352 (display "clearing file timestamps...\n")
353 (for-each (lambda (file)
354 (let ((s (lstat file)))
355 ;; XXX: Guile uses libc's 'utime' function
356 ;; (not 'futime'), so the timestamp of
357 ;; symlinks cannot be changed, and there
358 ;; are symlinks here pointing to
359 ;; /nix/store, which is the host,
361 (unless (eq? (stat:type s) 'symlink)
362 (utime file 0 0 0 0))))
363 (find-files "/fs" ".*"))
366 (system* grub "--no-floppy"
367 "--boot-directory" "/fs/boot"
369 (zero? (system* umount "/fs"))
372 #:inputs `(("parted" ,parted)
374 ("e2fsprogs" ,e2fsprogs)
375 ("grub.cfg" ,grub-configuration)
377 ;; For shell scripts.
378 ("sed" ,(car (assoc-ref %final-inputs "sed")))
379 ("grep" ,(car (assoc-ref %final-inputs "grep")))
380 ("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
381 ("findutils" ,(car (assoc-ref %final-inputs "findutils")))
382 ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
383 ("util-linux" ,util-linux)
385 ,@(if initialize-store?
386 `(("guix" ,guix-0.4))
390 #:make-disk-image? #t
391 #:disk-image-size disk-image-size
392 #:references-graphs (map input->name+derivation inputs-to-copy)
393 #:modules '((guix build utils)
394 (guix build linux-initrd))))
398 ;;; Stand-alone VM image.
401 (define* (union store inputs
402 #:key (guile (%guile-for-build)) (system (%current-system))
404 "Return a derivation that builds the union of INPUTS. INPUTS is a list of
408 (use-modules (guix build union))
410 (setvbuf (current-output-port) _IOLBF)
411 (setvbuf (current-error-port) _IOLBF)
413 (let ((output (assoc-ref %outputs "out"))
414 (inputs (map cdr %build-inputs)))
415 (format #t "building union `~a' with ~a packages...~%"
416 output (length inputs))
417 (union-build output inputs))))
419 (build-expression->derivation store name system builder
421 ((name (? package? p))
422 `(,name ,(package-derivation store p
424 ((name (? package? p) output)
425 `(,name ,(package-derivation store p
430 #:modules '((guix build union))
431 #:guile-for-build guile))
433 (define (system-qemu-image store)
434 "Return the derivation of a QEMU image of the GNU system."
436 (add-text-to-store store "motd" "
437 Happy birthday, GNU! http://www.gnu.org/gnu30
441 (define %pam-services
442 ;; Services known to PAM.
443 (list %pam-other-services
444 (unix-pam-service "login"
445 #:allow-empty-passwords? #t
448 (define %dmd-services
449 ;; Services run by dmd.
450 (list (host-name-service store "gnu")
451 (mingetty-service store "tty1")
452 (mingetty-service store "tty2")
453 (mingetty-service store "tty3")
454 (mingetty-service store "tty4")
455 (mingetty-service store "tty5")
456 (mingetty-service store "tty6")
457 (syslog-service store)
458 (guix-service store #:guix guix-0.4)
461 ;; QEMU networking settings.
462 (static-networking-service store "eth0" "10.0.2.10"
463 #:gateway "10.0.2.2")))
466 ;; Name resolution for default QEMU settings.
467 (add-text-to-store store "resolv.conf"
468 "nameserver 10.0.2.3\n"))
470 (parameterize ((%guile-for-build (package-derivation store guile-final)))
471 (let* ((bash-drv (package-derivation store bash))
472 (bash-file (string-append (derivation->output-path bash-drv)
474 (dmd-drv (package-derivation store dmd))
475 (dmd-file (string-append (derivation->output-path dmd-drv)
477 (dmd-conf (dmd-configuration-file store %dmd-services))
478 (accounts (list (user-account
482 (comment "System administrator")
485 (passwd (passwd-file store accounts))
486 (shadow (passwd-file store accounts #:shadow? #t))
487 (group (add-text-to-store store "group"
489 (pam.d-drv (pam-services->directory store %pam-services))
490 (pam.d (derivation->output-path pam.d-drv))
492 (packages `(("coreutils" ,coreutils)
497 ("libc" ,glibc-final)
498 ("inetutils" ,inetutils)
501 ;; TODO: Replace with a real profile with a manifest.
502 ;; TODO: Generate bashrc from packages' search-paths.
503 (profile-drv (union store packages
504 #:name "default-profile"))
505 (profile (derivation->output-path profile-drv))
506 (bashrc (add-text-to-store store "bashrc"
508 export PS1='\\u@\\h\\$ '
509 export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin
510 export CPATH=$HOME/.guix-profile/include:" profile "/include
511 export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib
512 alias ls='ls -p --color'
516 (issue (add-text-to-store store "issue" "
517 This is an alpha preview of the GNU system. Welcome.
519 This image features the GNU Guix package manager, which was used to
520 build it (http://www.gnu.org/software/guix/). The init system is
521 GNU dmd (http://www.gnu.org/software/dmd/).
523 You can log in as 'root' with no password.
526 (populate `((directory "/etc")
527 (directory "/var/log") ; for dmd
528 (directory "/var/run/nscd")
529 ("/etc/shadow" -> ,shadow)
530 ("/etc/passwd" -> ,passwd)
531 ("/etc/login.defs" -> "/dev/null")
532 ("/etc/pam.d" -> ,pam.d)
533 ("/etc/resolv.conf" -> ,resolv.conf)
534 ("/etc/profile" -> ,bashrc)
535 ("/etc/issue" -> ,issue)
536 (directory "/var/nix/gcroots")
537 ("/var/nix/gcroots/default-profile" -> ,profile)))
538 (out (derivation->output-path
539 (package-derivation store mingetty)))
540 (boot (add-text-to-store store "boot"
542 `(execl ,dmd-file "dmd"
543 "--config" ,dmd-conf))
545 (entries (list (menu-entry
546 (label (string-append
547 "GNU System with Linux-Libre "
548 (package-version linux-libre)
549 " (technology preview)"))
551 (linux-arguments `("--root=/dev/vda1"
552 ,(string-append "--load=" boot)))
553 (initrd gnu-system-initrd))))
554 (grub.cfg (grub-configuration-file store entries)))
556 #:grub-configuration grub.cfg
558 #:disk-image-size (* 500 (expt 2 20))
559 #:initialize-store? #t
560 #:inputs-to-copy `(("boot" ,boot)
561 ("linux" ,linux-libre)
562 ("initrd" ,gnu-system-initrd)
564 ("profile" ,profile-drv)
567 ("dmd.conf" ,dmd-conf)
568 ("etc-pam.d" ,pam.d-drv)
569 ("etc-passwd" ,passwd)
570 ("etc-shadow" ,shadow)
572 ("etc-resolv.conf" ,resolv.conf)
573 ("etc-bashrc" ,bashrc)
576 ,@(append-map service-inputs