-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (gnu system vm)
- #:use-module (guix config)
- #:use-module (guix store)
- #:use-module (guix derivations)
- #:use-module (guix packages)
- #:use-module (guix monads)
- #:use-module ((gnu packages base)
- #:select (%final-inputs
- guile-final gcc-final glibc-final
- ld-wrapper binutils-final
- coreutils findutils grep sed tzdata))
- #:use-module (gnu packages guile)
- #:use-module (gnu packages bash)
- #:use-module (gnu packages less)
- #:use-module (gnu packages qemu)
- #:use-module (gnu packages parted)
- #:use-module (gnu packages zile)
- #:use-module (gnu packages grub)
- #:use-module (gnu packages linux)
- #:use-module (gnu packages package-management)
- #:use-module ((gnu packages make-bootstrap)
- #:select (%guile-static-stripped))
- #:use-module (gnu packages admin)
-
- #:use-module (gnu system shadow)
- #:use-module (gnu system linux)
- #:use-module (gnu system linux-initrd)
- #:use-module (gnu system grub)
- #:use-module (gnu system)
- #:use-module (gnu services)
-
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
- #:use-module (ice-9 match)
-
- #:export (expression->derivation-in-linux-vm
- qemu-image
- system-qemu-image
- system-qemu-image/shared-store
- system-qemu-image/shared-store-script))
-
-\f
-;;; Commentary:
-;;;
-;;; Tools to evaluate build expressions within virtual machines.
-;;;
-;;; Code:
-
-(define* (expression->derivation-in-linux-vm name exp
- #:key
- (system (%current-system))
- (inputs '())
- (linux linux-libre)
- initrd
- (qemu qemu-headless)
- (env-vars '())
- (modules '())
- (guile-for-build
- (%guile-for-build))
-
- (make-disk-image? #f)
- (references-graphs #f)
- (memory-size 256)
- (disk-image-size
- (* 100 (expt 2 20))))
- "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
-derivation). In the virtual machine, EXP has access to all of INPUTS from the
-store; it should put its output files in the `/xchg' directory, which is
-copied to the derivation's output when the VM terminates. The virtual machine
-runs with MEMORY-SIZE MiB of memory.
-
-When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
-DISK-IMAGE-SIZE bytes and return it.
-
-When REFERENCES-GRAPHS is true, it must be a list of file name/store path
-pairs, as for `derivation'. The files containing the reference graphs are
-made available under the /xchg CIFS share."
- ;; FIXME: Allow use of macros from other modules, as done in
- ;; `build-expression->derivation'.
-
- (define input-alist
- (with-monad %store-monad
- (map (match-lambda
- ((input (? package? package))
- (mlet %store-monad ((out (package-file package #:system system)))
- (return `(,input . ,out))))
- ((input (? package? package) sub-drv)
- (mlet %store-monad ((out (package-file package
- #:output sub-drv
- #:system system)))
- (return `(,input . ,out))))
- ((input (? derivation? drv))
- (return `(,input . ,(derivation->output-path drv))))
- ((input (? derivation? drv) sub-drv)
- (return `(,input . ,(derivation->output-path drv sub-drv))))
- ((input (and (? string?) (? store-path?) file))
- (return `(,input . ,file))))
- inputs)))
-
- (define builder
- ;; Code that launches the VM that evaluates EXP.
- `(let ()
- (use-modules (guix build utils)
- (srfi srfi-1)
- (ice-9 rdelim))
-
- (let ((out (assoc-ref %outputs "out"))
- (cu (string-append (assoc-ref %build-inputs "coreutils")
- "/bin"))
- (qemu (string-append (assoc-ref %build-inputs "qemu")
- "/bin/qemu-system-"
- (car (string-split ,system #\-))))
- (img (string-append (assoc-ref %build-inputs "qemu")
- "/bin/qemu-img"))
- (linux (string-append (assoc-ref %build-inputs "linux")
- "/bzImage"))
- (initrd (string-append (assoc-ref %build-inputs "initrd")
- "/initrd"))
- (builder (assoc-ref %build-inputs "builder")))
-
- ;; XXX: QEMU uses "rm -rf" when it's done to remove the temporary SMB
- ;; directory, so it really needs `rm' in $PATH.
- (setenv "PATH" cu)
-
- ,(if make-disk-image?
- `(zero? (system* img "create" "-f" "qcow2" "image.qcow2"
- ,(number->string disk-image-size)))
- '(begin))
-
- (mkdir "xchg")
-
- ;; Copy the reference-graph files under xchg/ so EXP can access it.
- (begin
- ,@(match references-graphs
- (((graph-files . _) ...)
- (map (lambda (file)
- `(copy-file ,file
- ,(string-append "xchg/" file)))
- graph-files))
- (#f '())))
-
- (and (zero?
- (system* qemu "-enable-kvm" "-nographic" "-no-reboot"
- "-m" ,(number->string memory-size)
- "-net" "nic,model=virtio"
- "-virtfs"
- ,(string-append "local,id=store_dev,path=" (%store-prefix)
- ",security_model=none,mount_tag=store")
- "-virtfs"
- ,(string-append "local,id=xchg_dev,path=xchg"
- ",security_model=none,mount_tag=xchg")
- "-kernel" linux
- "-initrd" initrd
- "-append" (string-append "console=ttyS0 --load="
- builder)
- ,@(if make-disk-image?
- '("-hda" "image.qcow2")
- '())))
- ,(if make-disk-image?
- '(copy-file "image.qcow2" ; XXX: who mkdir'd OUT?
- out)
- '(begin
- (mkdir out)
- (copy-recursively "xchg" out)))))))
-
- (mlet* %store-monad
- ((input-alist (sequence %store-monad input-alist))
- (exp* -> `(let ((%build-inputs ',input-alist))
- ,exp))
- (user-builder (text-file "builder-in-linux-vm"
- (object->string exp*)))
- (coreutils -> (car (assoc-ref %final-inputs "coreutils")))
- (initrd (if initrd ; use the default initrd?
- (return initrd)
- (qemu-initrd #:guile-modules-in-chroot? #t
- #:mounts `((9p "store" ,(%store-prefix))
- (9p "xchg" "/xchg")))))
- (inputs (lower-inputs `(("qemu" ,qemu)
- ("linux" ,linux)
- ("initrd" ,initrd)
- ("coreutils" ,coreutils)
- ("builder" ,user-builder)
- ,@inputs))))
- (derivation-expression name builder
- ;; TODO: Require the "kvm" feature.
- #:system system
- #:inputs inputs
- #:env-vars env-vars
- #:modules (delete-duplicates
- `((guix build utils)
- ,@modules))
- #:guile-for-build guile-for-build
- #:references-graphs references-graphs)))
-
-(define* (qemu-image #:key
- (name "qemu-image")
- (system (%current-system))
- (disk-image-size (* 100 (expt 2 20)))
- grub-configuration
- (initialize-store? #f)
- (populate #f)
- (inputs '())
- (inputs-to-copy '()))
- "Return a bootable, stand-alone QEMU image. The returned image is a full
-disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
-configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.)
-
-INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
-into the image being built. When INITIALIZE-STORE? is true, initialize the
-store database in the image so that Guix can be used in the image.
-
-POPULATE is a list of directives stating directories or symlinks to be created
-in the disk image partition. It is evaluated once the image has been
-populated with INPUTS-TO-COPY. It can be used to provide additional files,
-such as /etc files."
- (define (input->name+derivation tuple)
- (with-monad %store-monad
- (match tuple
- ((name (? package? package))
- (mlet %store-monad ((drv (package->derivation package system)))
- (return `(,name . ,(derivation->output-path drv)))))
- ((name (? package? package) sub-drv)
- (mlet %store-monad ((drv (package->derivation package system)))
- (return `(,name . ,(derivation->output-path drv sub-drv)))))
- ((name (? derivation? drv))
- (return `(,name . ,(derivation->output-path drv))))
- ((name (? derivation? drv) sub-drv)
- (return `(,name . ,(derivation->output-path drv sub-drv))))
- ((input (and (? string?) (? store-path?) file))
- (return `(,input . ,file))))))
-
- (mlet %store-monad
- ((graph (sequence %store-monad
- (map input->name+derivation inputs-to-copy))))
- (expression->derivation-in-linux-vm
- "qemu-image"
- `(let ()
- (use-modules (ice-9 rdelim)
- (srfi srfi-1)
- (guix build utils)
- (guix build linux-initrd))
-
- (let ((parted (string-append (assoc-ref %build-inputs "parted")
- "/sbin/parted"))
- (mkfs (string-append (assoc-ref %build-inputs "e2fsprogs")
- "/sbin/mkfs.ext3"))
- (grub (string-append (assoc-ref %build-inputs "grub")
- "/sbin/grub-install"))
- (umount (string-append (assoc-ref %build-inputs "util-linux")
- "/bin/umount")) ; XXX: add to Guile
- (grub.cfg ,grub-configuration))
-
- (define (read-reference-graph port)
- ;; Return a list of store paths from the reference graph at PORT.
- ;; The data at PORT is the format produced by #:references-graphs.
- (let loop ((line (read-line port))
- (result '()))
- (cond ((eof-object? line)
- (delete-duplicates result))
- ((string-prefix? "/" line)
- (loop (read-line port)
- (cons line result)))
- (else
- (loop (read-line port)
- result)))))
-
- (define (things-to-copy)
- ;; Return the list of store files to copy to the image.
- (define (graph-from-file file)
- (call-with-input-file file
- read-reference-graph))
-
- ,(match inputs-to-copy
- (((graph-files . _) ...)
- `(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
- graph-files))
- (paths (append-map graph-from-file graph-files)))
- (delete-duplicates paths)))
- (#f ''())))
-
- ;; GRUB is full of shell scripts.
- (setenv "PATH"
- (string-append (dirname grub) ":"
- (assoc-ref %build-inputs "coreutils") "/bin:"
- (assoc-ref %build-inputs "findutils") "/bin:"
- (assoc-ref %build-inputs "sed") "/bin:"
- (assoc-ref %build-inputs "grep") "/bin:"
- (assoc-ref %build-inputs "gawk") "/bin"))
-
- (display "creating partition table...\n")
- (and (zero? (system* parted "/dev/sda" "mklabel" "msdos"
- "mkpart" "primary" "ext2" "1MiB"
- ,(format #f "~aB"
- (- disk-image-size
- (* 5 (expt 2 20))))))
- (begin
- (display "creating ext3 partition...\n")
- (and (zero? (system* mkfs "-F" "/dev/sda1"))
- (let ((store (string-append "/fs" ,(%store-prefix))))
- (display "mounting partition...\n")
- (mkdir "/fs")
- (mount "/dev/sda1" "/fs" "ext3")
- (mkdir-p "/fs/boot/grub")
- (symlink grub.cfg "/fs/boot/grub/grub.cfg")
-
- ;; Populate the image's store.
- (mkdir-p store)
- (chmod store #o1775)
- (for-each (lambda (thing)
- (copy-recursively thing
- (string-append "/fs"
- thing)))
- (things-to-copy))
-
- ;; Populate /dev.
- (make-essential-device-nodes #:root "/fs")
-
- ;; Optionally, register the inputs in the image's store.
- (let* ((guix (assoc-ref %build-inputs "guix"))
- (register (and guix
- (string-append guix
- "/sbin/guix-register"))))
- ,@(if initialize-store?
- (match inputs-to-copy
- (((graph-files . _) ...)
- (map (lambda (closure)
- `(system* register "--prefix" "/fs"
- ,(string-append "/xchg/"
- closure)))
- graph-files)))
- '(#f)))
-
- ;; Evaluate the POPULATE directives.
- ,@(let loop ((directives populate)
- (statements '()))
- (match directives
- (()
- (reverse statements))
- ((('directory name) rest ...)
- (loop rest
- (cons `(mkdir-p ,(string-append "/fs" name))
- statements)))
- ((('directory name uid gid) rest ...)
- (let ((dir (string-append "/fs" name)))
- (loop rest
- (cons* `(chown ,dir ,uid ,gid)
- `(mkdir-p ,dir)
- statements))))
- (((new '-> old) rest ...)
- (loop rest
- (cons `(symlink ,old
- ,(string-append "/fs" new))
- statements)))))
-
- (and=> (assoc-ref %build-inputs "populate")
- (lambda (populate)
- (chdir "/fs")
- (primitive-load populate)
- (chdir "/")))
-
- (display "clearing file timestamps...\n")
- (for-each (lambda (file)
- (let ((s (lstat file)))
- ;; XXX: Guile uses libc's 'utime' function
- ;; (not 'futime'), so the timestamp of
- ;; symlinks cannot be changed, and there
- ;; are symlinks here pointing to
- ;; /gnu/store, which is the host,
- ;; read-only store.
- (unless (eq? (stat:type s) 'symlink)
- (utime file 0 0 0 0))))
- (find-files "/fs" ".*"))
-
- (and (zero?
- (system* grub "--no-floppy"
- "--boot-directory" "/fs/boot"
- "/dev/sda"))
- (begin
- (when (file-exists? "/fs/dev/pts")
- ;; Unmount devpts so /fs itself can be
- ;; unmounted (failing to do that leads to
- ;; EBUSY.)
- (system* umount "/fs/dev/pts"))
- (zero? (system* umount "/fs")))
- (reboot))))))))
- #:system system
- #:inputs `(("parted" ,parted)
- ("grub" ,grub)
- ("e2fsprogs" ,e2fsprogs)
-
- ;; For shell scripts.
- ("sed" ,(car (assoc-ref %final-inputs "sed")))
- ("grep" ,(car (assoc-ref %final-inputs "grep")))
- ("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
- ("findutils" ,(car (assoc-ref %final-inputs "findutils")))
- ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
- ("util-linux" ,util-linux)
-
- ,@(if initialize-store?
- `(("guix" ,guix))
- '())
-
- ,@inputs-to-copy)
- #:make-disk-image? #t
- #:disk-image-size disk-image-size
- #:references-graphs graph
- #:modules '((guix build utils)
- (guix build linux-initrd)))))
-
-\f
-;;;
-;;; Stand-alone VM image.
-;;;
-
-(define (operating-system-build-gid os)
- "Return as a monadic value the group id for build users of OS, or #f."
- (anym %store-monad
- (lambda (service)
- (and (equal? '(guix-daemon)
- (service-provision service))
- (match (service-user-groups service)
- ((group)
- (user-group-id group)))))
- (operating-system-services os)))
-
-(define (operating-system-default-contents os)
- "Return a list of directives suitable for 'system-qemu-image' describing the
-basic contents of the root file system of OS."
- (define (user-directories user)
- (let ((home (user-account-home-directory user))
- ;; XXX: Deal with automatically allocated ids.
- (uid (or (user-account-uid user) 0))
- (gid (or (user-account-gid user) 0))
- (root (string-append "/var/guix/profiles/per-user/"
- (user-account-name user))))
- `((directory ,root ,uid ,gid)
- (directory ,home ,uid ,gid))))
-
- (mlet* %store-monad ((os-drv (operating-system-derivation os))
- (os-dir -> (derivation->output-path os-drv))
- (build-gid (operating-system-build-gid os))
- (profile (operating-system-profile-directory os)))
- (return `((directory ,(%store-prefix) 0 ,(or build-gid 0))
- (directory "/etc")
- (directory "/var/log") ; for dmd
- (directory "/var/run/nscd")
- (directory "/var/guix/gcroots")
- ("/var/guix/gcroots/system" -> ,os-dir)
- (directory "/run")
- ("/run/current-system" -> ,profile)
- (directory "/bin")
- ("/bin/sh" -> "/run/current-system/bin/bash")
- (directory "/tmp")
- (directory "/var/guix/profiles/per-user/root" 0 0)
-
- (directory "/root" 0 0) ; an exception
- ,@(append-map user-directories
- (operating-system-users os))))))
-
-(define* (system-qemu-image os
- #:key (disk-image-size (* 900 (expt 2 20))))
- "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU
-system as described by OS."
- (mlet* %store-monad
- ((os-drv (operating-system-derivation os))
- (os-dir -> (derivation->output-path os-drv))
- (grub.cfg -> (string-append os-dir "/grub.cfg"))
- (populate (operating-system-default-contents os)))
- (qemu-image #:grub-configuration grub.cfg
- #:populate populate
- #:disk-image-size disk-image-size
- #:initialize-store? #t
- #:inputs-to-copy `(("system" ,os-drv)))))
-
-(define* (system-qemu-image/shared-store
- os
- #:key (disk-image-size (* 15 (expt 2 20))))
- "Return a derivation that builds a QEMU image of OS that shares its store
-with the host."
- (mlet* %store-monad
- ((os-drv (operating-system-derivation os))
- (os-dir -> (derivation->output-path os-drv))
- (grub.cfg -> (string-append os-dir "/grub.cfg"))
- (populate (operating-system-default-contents os)))
- ;; TODO: Initialize the database so Guix can be used in the guest.
- (qemu-image #:grub-configuration grub.cfg
- #:populate populate
- #:disk-image-size disk-image-size)))
-
-(define* (system-qemu-image/shared-store-script
- os
- #:key
- (qemu qemu)
- (graphic? #t))
- "Return a derivation that builds a script to run a virtual machine image of
-OS that shares its store with the host."
- (let* ((initrd (qemu-initrd #:mounts `((9p "store" ,(%store-prefix)))
- #:volatile-root? #t))
- (os (operating-system (inherit os) (initrd initrd))))
- (define builder
- (mlet %store-monad ((image (system-qemu-image/shared-store os))
- (qemu (package-file qemu
- "bin/qemu-system-x86_64"))
- (bash (package-file bash "bin/sh"))
- (kernel (package-file (operating-system-kernel os)
- "bzImage"))
- (initrd initrd)
- (os-drv (operating-system-derivation os)))
- (return `(let ((out (assoc-ref %outputs "out")))
- (call-with-output-file out
- (lambda (port)
- (display
- (string-append "#!" ,bash "
-exec " ,qemu " -enable-kvm -no-reboot -net nic,model=virtio \
- -virtfs local,path=" ,(%store-prefix) ",security_model=none,mount_tag=store \
- -net user \
- -kernel " ,kernel " -initrd "
- ,(string-append (derivation->output-path initrd) "/initrd") " \
--append \"" ,(if graphic? "" "console=ttyS0 ")
-"--load=" ,(derivation->output-path os-drv) "/boot --root=/dev/vda1\" \
- -drive file=" ,(derivation->output-path image)
- ",if=virtio,cache=writeback,werror=report,readonly\n")
- port)))
- (chmod out #o555)
- #t))))
-
- (mlet %store-monad ((image (system-qemu-image/shared-store os))
- (initrd initrd)
- (qemu (package->derivation qemu))
- (bash (package->derivation bash))
- (os (operating-system-derivation os))
- (builder builder))
- (derivation-expression "run-vm.sh" builder
- #:inputs `(("qemu" ,qemu)
- ("image" ,image)
- ("bash" ,bash)
- ("initrd" ,initrd)
- ("os" ,os))))))
-
-;;; vm.scm ends here
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system vm)
+ #:use-module (guix config)
+ #:use-module (guix store)
+ #:use-module (guix gexp)
+ #:use-module (guix derivations)
+ #:use-module (guix packages)
+ #:use-module (guix monads)
+ #:use-module (guix records)
+
+ #:use-module ((gnu build vm)
+ #:select (qemu-command))
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages guile)
+ #:use-module (gnu packages gawk)
+ #:use-module (gnu packages bash)
+ #:use-module (gnu packages less)
+ #:use-module (gnu packages qemu)
+ #:use-module (gnu packages disk)
+ #:use-module (gnu packages zile)
+ #:use-module (gnu packages grub)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu packages package-management)
+ #:use-module ((gnu packages make-bootstrap)
+ #:select (%guile-static-stripped))
+ #:use-module (gnu packages admin)
+
+ #:use-module (gnu system shadow)
+ #:use-module (gnu system linux)
+ #:use-module (gnu system linux-initrd)
+ #:use-module (gnu system grub)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu system)
+ #:use-module (gnu services)
+
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+
+ #:export (expression->derivation-in-linux-vm
+ qemu-image
+ system-qemu-image
+
+ system-qemu-image/shared-store
+ system-qemu-image/shared-store-script
+ system-disk-image))
+
+\f
+;;; Commentary:
+;;;
+;;; Tools to evaluate build expressions within virtual machines.
+;;;
+;;; Code:
+
+(define %linux-vm-file-systems
+ ;; File systems mounted for 'derivation-in-linux-vm'. The store and /xchg
+ ;; directory are shared with the host over 9p.
+ (list (file-system
+ (mount-point (%store-prefix))
+ (device "store")
+ (type "9p")
+ (needed-for-boot? #t)
+ (options "trans=virtio")
+ (check? #f))
+ (file-system
+ (mount-point "/xchg")
+ (device "xchg")
+ (type "9p")
+ (needed-for-boot? #t)
+ (options "trans=virtio")
+ (check? #f))))
+
+(define* (expression->derivation-in-linux-vm name exp
+ #:key
+ (system (%current-system))
+ (linux linux-libre)
+ initrd
+ (qemu qemu-headless)
+ (env-vars '())
+ (modules
+ '((gnu build vm)
+ (gnu build install)
+ (gnu build linux-boot)
+ (gnu build linux-modules)
+ (gnu build file-systems)
+ (guix elf)
+ (guix records)
+ (guix build utils)
+ (guix build syscalls)
+ (guix build store-copy)))
+ (guile-for-build
+ (%guile-for-build))
+
+ (make-disk-image? #f)
+ (references-graphs #f)
+ (memory-size 256)
+ (disk-image-format "qcow2")
+ (disk-image-size
+ (* 100 (expt 2 20))))
+ "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
+derivation). In the virtual machine, EXP has access to all its inputs from the
+store; it should put its output files in the `/xchg' directory, which is
+copied to the derivation's output when the VM terminates. The virtual machine
+runs with MEMORY-SIZE MiB of memory.
+
+When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
+DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
+return it.
+
+MODULES is the set of modules imported in the execution environment of EXP.
+
+When REFERENCES-GRAPHS is true, it must be a list of file name/store path
+pairs, as for `derivation'. The files containing the reference graphs are
+made available under the /xchg CIFS share."
+ (mlet* %store-monad
+ ((module-dir (imported-modules modules))
+ (compiled (compiled-modules modules))
+ (user-builder (gexp->file "builder-in-linux-vm" exp))
+ (loader (gexp->file "linux-vm-loader"
+ #~(begin
+ (set! %load-path
+ (cons #$module-dir %load-path))
+ (set! %load-compiled-path
+ (cons #$compiled
+ %load-compiled-path))
+ (primitive-load #$user-builder))))
+ (coreutils -> (canonical-package coreutils))
+ (initrd (if initrd ; use the default initrd?
+ (return initrd)
+ (base-initrd %linux-vm-file-systems
+ #:linux linux
+ #:virtio? #t
+ #:qemu-networking? #t))))
+
+ (define builder
+ ;; Code that launches the VM that evaluates EXP.
+ #~(begin
+ (use-modules (guix build utils)
+ (gnu build vm))
+
+ (let ((inputs '#$(list qemu coreutils))
+ (linux (string-append #$linux "/bzImage"))
+ (initrd (string-append #$initrd "/initrd"))
+ (loader #$loader)
+ (graphs '#$(match references-graphs
+ (((graph-files . _) ...) graph-files)
+ (_ #f))))
+
+ (set-path-environment-variable "PATH" '("bin") inputs)
+
+ (load-in-linux-vm loader
+ #:output #$output
+ #:linux linux #:initrd initrd
+ #:memory-size #$memory-size
+ #:make-disk-image? #$make-disk-image?
+ #:disk-image-format #$disk-image-format
+ #:disk-image-size #$disk-image-size
+ #:references-graphs graphs))))
+
+ (gexp->derivation name builder
+ ;; TODO: Require the "kvm" feature.
+ #:system system
+ #:env-vars env-vars
+ #:modules modules
+ #:guile-for-build guile-for-build
+ #:references-graphs references-graphs)))
+
+(define* (qemu-image #:key
+ (name "qemu-image")
+ (system (%current-system))
+ (qemu qemu-headless)
+ (disk-image-size (* 100 (expt 2 20)))
+ (disk-image-format "qcow2")
+ (file-system-type "ext4")
+ file-system-label
+ os-derivation
+ grub-configuration
+ (register-closures? #t)
+ (inputs '())
+ copy-inputs?)
+ "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
+'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
+Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
+partition. The returned image is a full disk image that runs OS-DERIVATION,
+with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
+file (GRUB-CONFIGURATION must be the name of a file in the VM.)
+
+INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
+all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
+register INPUTS in the store database of the image so that Guix can be used in
+the image."
+ (expression->derivation-in-linux-vm
+ name
+ #~(begin
+ (use-modules (gnu build vm)
+ (guix build utils))
+
+ (let ((inputs
+ '#$(append (list qemu parted grub e2fsprogs)
+ (map canonical-package
+ (list sed grep coreutils findutils gawk))
+ (if register-closures? (list guix) '())))
+
+ ;; This variable is unused but allows us to add INPUTS-TO-COPY
+ ;; as inputs.
+ (to-register
+ '#$(map (match-lambda
+ ((name thing) thing)
+ ((name thing output) `(,thing ,output)))
+ inputs)))
+
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+
+ (let* ((graphs '#$(match inputs
+ (((names . _) ...)
+ names)))
+ (initialize (root-partition-initializer
+ #:closures graphs
+ #:copy-closures? #$copy-inputs?
+ #:register-closures? #$register-closures?
+ #:system-directory #$os-derivation))
+ (partitions (list (partition
+ (size #$(- disk-image-size
+ (* 10 (expt 2 20))))
+ (label #$file-system-label)
+ (file-system #$file-system-type)
+ (bootable? #t)
+ (initializer initialize)))))
+ (initialize-hard-disk "/dev/vda"
+ #:partitions partitions
+ #:grub.cfg #$grub-configuration)
+ (reboot))))
+ #:system system
+ #:make-disk-image? #t
+ #:disk-image-size disk-image-size
+ #:disk-image-format disk-image-format
+ #:references-graphs inputs))
+
+\f
+;;;
+;;; VM and disk images.
+;;;
+
+(define* (system-disk-image os
+ #:key
+ (name "disk-image")
+ (file-system-type "ext4")
+ (disk-image-size (* 900 (expt 2 20)))
+ (volatile? #t))
+ "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
+system described by OS. Said image can be copied on a USB stick as is. When
+VOLATILE? is true, the root file system is made volatile; this is useful
+to USB sticks meant to be read-only."
+ (define root-label
+ ;; Volume name of the root file system. Since we don't know which device
+ ;; will hold it, we use the volume name to find it (using the UUID would
+ ;; be even better, but somewhat less convenient.)
+ "gnu-disk-image")
+
+ (define file-systems-to-keep
+ (remove (lambda (fs)
+ (string=? (file-system-mount-point fs) "/"))
+ (operating-system-file-systems os)))
+
+ (let ((os (operating-system (inherit os)
+ ;; Since this is meant to be used on real hardware, don't
+ ;; install QEMU networking or anything like that. Assume USB
+ ;; mass storage devices (usb-storage.ko) are available.
+ (initrd (lambda (file-systems . rest)
+ (apply base-initrd file-systems
+ #:volatile-root? #t
+ rest)))
+
+ ;; Force our own root file system.
+ (file-systems (cons (file-system
+ (mount-point "/")
+ (device root-label)
+ (title 'label)
+ (type file-system-type))
+ file-systems-to-keep)))))
+
+ (mlet* %store-monad ((os-drv (operating-system-derivation os))
+ (grub.cfg (operating-system-grub.cfg os)))
+ (qemu-image #:name name
+ #:os-derivation os-drv
+ #:grub-configuration grub.cfg
+ #:disk-image-size disk-image-size
+ #:disk-image-format "raw"
+ #:file-system-type file-system-type
+ #:file-system-label root-label
+ #:copy-inputs? #t
+ #:register-closures? #t
+ #:inputs `(("system" ,os-drv)
+ ("grub.cfg" ,grub.cfg))))))
+
+(define* (system-qemu-image os
+ #:key
+ (file-system-type "ext4")
+ (disk-image-size (* 900 (expt 2 20))))
+ "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
+of the GNU system as described by OS."
+ (define file-systems-to-keep
+ ;; Keep only file systems other than root and not normally bound to real
+ ;; devices.
+ (remove (lambda (fs)
+ (let ((target (file-system-mount-point fs))
+ (source (file-system-device fs)))
+ (or (string=? target "/")
+ (string-prefix? "/dev/" source))))
+ (operating-system-file-systems os)))
+
+ (let ((os (operating-system (inherit os)
+ ;; Use an initrd with the whole QEMU shebang.
+ (initrd (lambda (file-systems . rest)
+ (apply base-initrd file-systems
+ #:virtio? #t
+ #:qemu-networking? #t
+ rest)))
+
+ ;; Force our own root file system.
+ (file-systems (cons (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type file-system-type))
+ file-systems-to-keep)))))
+ (mlet* %store-monad
+ ((os-drv (operating-system-derivation os))
+ (grub.cfg (operating-system-grub.cfg os)))
+ (qemu-image #:os-derivation os-drv
+ #:grub-configuration grub.cfg
+ #:disk-image-size disk-image-size
+ #:file-system-type file-system-type
+ #:inputs `(("system" ,os-drv)
+ ("grub.cfg" ,grub.cfg))
+ #:copy-inputs? #t))))
+
+\f
+;;;
+;;; VMs that share file systems with the host.
+;;;
+
+(define (file-system->mount-tag fs)
+ "Return a 9p mount tag for host file system FS."
+ ;; QEMU mount tags cannot contain slashes and cannot start with '_'.
+ ;; Compute an identifier that corresponds to the rules.
+ (string-append "TAG"
+ (string-map (match-lambda
+ (#\/ #\_)
+ (chr chr))
+ fs)))
+
+(define (mapping->file-system mapping)
+ "Return a 9p file system that realizes MAPPING."
+ (match mapping
+ (($ <file-system-mapping> source target writable?)
+ (file-system
+ (mount-point target)
+ (device (file-system->mount-tag source))
+ (type "9p")
+ (flags (if writable? '() '(read-only)))
+ (options (string-append "trans=virtio"))
+ (check? #f)
+ (create-mount-point? #t)))))
+
+(define (virtualized-operating-system os mappings)
+ "Return an operating system based on OS suitable for use in a virtualized
+environment with the store shared with the host. MAPPINGS is a list of
+<file-system-mapping> to realize in the virtualized OS."
+ (define user-file-systems
+ ;; Remove file systems that conflict with those added below, or that are
+ ;; normally bound to real devices.
+ (remove (lambda (fs)
+ (let ((target (file-system-mount-point fs))
+ (source (file-system-device fs)))
+ (or (string=? target (%store-prefix))
+ (string=? target "/")
+ (string-prefix? "/dev/" source))))
+ (operating-system-file-systems os)))
+
+ (operating-system (inherit os)
+ (initrd (lambda (file-systems . rest)
+ (apply base-initrd file-systems
+ #:volatile-root? #t
+ #:virtio? #t
+ #:qemu-networking? #t
+ rest)))
+
+ ;; Disable swap.
+ (swap-devices '())
+
+ (file-systems (cons* (file-system
+ (mount-point "/")
+ (device "/dev/vda1")
+ (type "ext4"))
+
+ (file-system (inherit
+ (mapping->file-system %store-mapping))
+ (needed-for-boot? #t))
+
+ (append (map mapping->file-system mappings)
+ user-file-systems)))))
+
+(define* (system-qemu-image/shared-store
+ os
+ #:key
+ full-boot?
+ (disk-image-size (* (if full-boot? 500 15) (expt 2 20))))
+ "Return a derivation that builds a QEMU image of OS that shares its store
+with the host.
+
+When FULL-BOOT? is true, return an image that does a complete boot sequence,
+bootloaded included; thus, make a disk image that contains everything the
+bootloader refers to: OS kernel, initrd, bootloader data, etc."
+ (mlet* %store-monad ((os-drv (operating-system-derivation os))
+ (grub.cfg (operating-system-grub.cfg os)))
+ ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
+ ;; GRUB.CFG and all its dependencies, including the output of OS-DRV.
+ ;; This is more than needed (we only need the kernel, initrd, GRUB for its
+ ;; font, and the background image), but it's hard to filter that.
+ (qemu-image #:os-derivation os-drv
+ #:grub-configuration grub.cfg
+ #:disk-image-size disk-image-size
+ #:inputs (if full-boot?
+ `(("grub.cfg" ,grub.cfg))
+ '())
+
+ ;; XXX: Passing #t here is too slow, so let it off by default.
+ #:register-closures? #f
+ #:copy-inputs? full-boot?)))
+
+(define* (common-qemu-options image shared-fs)
+ "Return the a string-value gexp with the common QEMU options to boot IMAGE,
+with '-virtfs' options for the host file systems listed in SHARED-FS."
+ (define (virtfs-option fs)
+ #~(string-append "-virtfs local,path=\"" #$fs
+ "\",security_model=none,mount_tag=\""
+ #$(file-system->mount-tag fs)
+ "\" "))
+
+ #~(string-append
+ " -enable-kvm -no-reboot -net nic,model=virtio \
+ " #$@(map virtfs-option shared-fs) " \
+ -net user \
+ -serial stdio -vga std \
+ -drive file=" #$image
+ ",if=virtio,cache=writeback,werror=report,readonly \
+ -m 256"))
+
+(define* (system-qemu-image/shared-store-script os
+ #:key
+ (qemu qemu)
+ (graphic? #t)
+ (mappings '())
+ full-boot?
+ (disk-image-size
+ (* (if full-boot? 500 15)
+ (expt 2 20))))
+ "Return a derivation that builds a script to run a virtual machine image of
+OS that shares its store with the host.
+
+MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
+systems into the guest.
+
+When FULL-BOOT? is true, the returned script runs everything starting from the
+bootloader; otherwise it directly starts the operating system kernel. The
+DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
+it is mostly useful when FULL-BOOT? is true."
+ (mlet* %store-monad ((os -> (virtualized-operating-system os mappings))
+ (os-drv (operating-system-derivation os))
+ (image (system-qemu-image/shared-store
+ os
+ #:full-boot? full-boot?
+ #:disk-image-size disk-image-size)))
+ (define builder
+ #~(call-with-output-file #$output
+ (lambda (port)
+ (display
+ (string-append "#!" #$bash "/bin/sh
+exec " #$qemu "/bin/" #$(qemu-command (%current-system))
+
+#$@(if full-boot?
+ #~()
+ #~(" -kernel " #$(operating-system-kernel os) "/bzImage \
+ -initrd " #$os-drv "/initrd \
+ -append \"" #$(if graphic? "" "console=ttyS0 ")
+ "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1 "
+ (string-join (list #+@(operating-system-kernel-arguments os))) "\" "))
+#$(common-qemu-options image
+ (map file-system-mapping-source
+ (cons %store-mapping mappings)))
+" \"$@\"\n")
+ port)
+ (chmod port #o555))))
+
+ (gexp->derivation "run-vm.sh" builder)))
+
+;;; vm.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff