me/guix
Archived
1
0
Fork 0
Code Activity
This repository has been archived on 2024-08-07. You can view files and clone it, but cannot push or open issues or pull requests.
guix/gnu/system/vm.scm
Chris Marusich a335f6fcc9
system: Add "guix system docker-image" command. 
* gnu/system/vm.scm (system-docker-image): New procedure.
* guix/scripts/system.scm (system-derivation-for-action): Add a case for
  docker-image, and in that case, call system-docker-image.
  (show-help): Document docker-image.
  (guix-system): Parse arguments for docker-image.
* doc/guix.texi (Invoking guix system): Document "guix system
  docker-image".
* gnu/system/examples/docker-image.tmpl: New file.
2018-03-24 03:04:11 +01:00

921 lines
40 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; 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 docker)
#: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 (guix modules)
#:use-module (guix scripts pack)
#:use-module (guix utils)
#:use-module (guix hash)
#:use-module (guix base32)
#:use-module ((gnu build vm)
#:select (qemu-command))
#:use-module (gnu packages base)
#:use-module (gnu packages bootloaders)
#:use-module (gnu packages cdrom)
#:use-module (gnu packages compression)
#:use-module (gnu packages guile)
#:autoload (gnu packages gnupg) (libgcrypt)
#:use-module (gnu packages gawk)
#:use-module (gnu packages bash)
#:use-module (gnu packages less)
#:use-module (gnu packages virtualization)
#:use-module (gnu packages disk)
#:use-module (gnu packages zile)
#: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 bootloader)
#:use-module (gnu bootloader grub)
#:use-module (gnu system shadow)
#:use-module (gnu system pam)
#:use-module (gnu system linux-initrd)
#:use-module (gnu bootloader)
#:use-module (gnu system file-systems)
#:use-module (gnu system)
#:use-module (gnu services)
#:use-module (gnu system uuid)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:export (expression->derivation-in-linux-vm
qemu-image
virtualized-operating-system
system-qemu-image
system-qemu-image/shared-store
system-qemu-image/shared-store-script
system-disk-image
system-docker-image
virtual-machine
virtual-machine?))
;;; Commentary:
;;;
;;; Tools to evaluate build expressions within virtual machines.
;;;
;;; Code:
(define %linux-vm-file-systems
;; File systems mounted for 'derivation-in-linux-vm'. These 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))
(file-system
(mount-point "/tmp")
(device "tmp")
(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-minimal)
(env-vars '())
(guile-for-build
(%guile-for-build))
(single-file-output? #f)
(make-disk-image? #f)
(references-graphs #f)
(memory-size 256)
(disk-image-format "qcow2")
(disk-image-size 'guess))
"Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the
virtual machine, EXP has access to all its inputs from the store; it should
put its output file(s) in the '/xchg' directory.
If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
Otherwise, copy the contents of /xchg to a new directory OUTPUT.
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. When DISK-IMAGE-SIZE is 'guess, estimate the image size based
based on the size of the closure of REFERENCES-GRAPHS.
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
((user-builder (gexp->file "builder-in-linux-vm" exp))
(loader (gexp->file "linux-vm-loader"
#~(primitive-load #$user-builder)))
(coreutils -> (canonical-package coreutils))
(initrd (if initrd ; use the default initrd?
(return initrd)
(base-initrd %linux-vm-file-systems
#:on-error 'backtrace
#:linux linux
#:linux-modules %base-initrd-modules
#:qemu-networking? #t))))
(define builder
;; Code that launches the VM that evaluates EXP.
(with-imported-modules (source-module-closure '((guix build utils)
(gnu build vm)))
#~(begin
(use-modules (guix build utils)
(gnu build vm))
(let* ((inputs '#$(list qemu coreutils))
(linux (string-append #$linux "/"
#$(system-linux-image-file-name)))
(initrd (string-append #$initrd "/initrd"))
(loader #$loader)
(graphs '#$(match references-graphs
(((graph-files . _) ...) graph-files)
(_ #f)))
(size #$(if (eq? 'guess disk-image-size)
#~(+ (* 70 (expt 2 20)) ;ESP
(estimated-partition-size graphs))
disk-image-size)))
(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?
#:single-file-output? #$single-file-output?
;; FIXME: ‘target-arm32?’ may not operate on
;; the right system/target values. Rewrite
;; using ‘let-system’ when available.
#:target-arm32? #$(target-arm32?)
#:disk-image-format #$disk-image-format
#:disk-image-size size
#:references-graphs graphs)))))
(gexp->derivation name builder
;; TODO: Require the "kvm" feature.
#:system system
#:env-vars env-vars
#:guile-for-build guile-for-build
#:references-graphs references-graphs)))
(define* (iso9660-image #:key
(name "iso9660-image")
file-system-label
file-system-uuid
(system (%current-system))
(qemu qemu-minimal)
os-drv
bootcfg-drv
bootloader
register-closures?
(inputs '()))
"Return a bootable, stand-alone iso9660 image.
INPUTS is a list of inputs (as for packages)."
(expression->derivation-in-linux-vm
name
(with-imported-modules (source-module-closure '((gnu build vm)
(guix build utils)))
#~(begin
(use-modules (gnu build vm)
(guix build utils))
(let ((inputs
'#$(append (list qemu parted e2fsprogs dosfstools xorriso)
(map canonical-package
(list sed grep coreutils findutils gawk))
(if register-closures? (list guix) '())))
(graphs '#$(match inputs
(((names . _) ...)
names)))
;; 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)
(make-iso9660-image #$(bootloader-package bootloader)
#$bootcfg-drv
#$os-drv
"/xchg/guixsd.iso"
#:register-closures? #$register-closures?
#:closures graphs
#:volume-id #$file-system-label
#:volume-uuid #$(and=> file-system-uuid
uuid-bytevector))
(reboot))))
#:system system
#:make-disk-image? #f
#:single-file-output? #t
#:references-graphs inputs))
(define* (qemu-image #:key
(name "qemu-image")
(system (%current-system))
(qemu qemu-minimal)
(disk-image-size 'guess)
(disk-image-format "qcow2")
(file-system-type "ext4")
file-system-label
file-system-uuid
os-drv
bootcfg-drv
bootloader
(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; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
partition (a UUID object).
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
(with-imported-modules (source-module-closure '((gnu build bootloader)
(gnu build vm)
(guix build utils)))
#~(begin
(use-modules (gnu build bootloader)
(gnu build vm)
(guix build utils)
(srfi srfi-26)
(ice-9 binary-ports))
(let ((inputs
'#$(append (list qemu parted e2fsprogs dosfstools)
(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-drv))
(root-size #$(if (eq? 'guess disk-image-size)
#~(max
;; Minimum 20 MiB root size
(* 20 (expt 2 20))
(estimated-partition-size
(map (cut string-append "/xchg/" <>)
graphs)))
(- disk-image-size
(* 50 (expt 2 20)))))
(partitions
(append
(list (partition
(size root-size)
(label #$file-system-label)
(uuid #$(and=> file-system-uuid
uuid-bytevector))
(file-system #$file-system-type)
(flags '(boot))
(initializer initialize)))
;; Append a small EFI System Partition for use with UEFI
;; bootloaders if we are not targeting ARM because UEFI
;; support in U-Boot is experimental.
;;
;; FIXME: ‘target-arm32?’ may be not operate on the right
;; system/target values. Rewrite using ‘let-system’ when
;; available.
(if #$(target-arm32?)
'()
(list (partition
;; The standalone grub image is about 10MiB, but
;; leave some room for custom or multiple images.
(size (* 40 (expt 2 20)))
(label "GNU-ESP") ;cosmetic only
;; Use "vfat" here since this property is used
;; when mounting. The actual FAT-ness is based
;; on file system size (16 in this case).
(file-system "vfat")
(flags '(esp))))))))
(initialize-hard-disk "/dev/vda"
#:partitions partitions
#:grub-efi #$grub-efi
#:bootloader-package
#$(bootloader-package bootloader)
#:bootcfg #$bootcfg-drv
#:bootcfg-location
#$(bootloader-configuration-file bootloader)
#:bootloader-installer
#$(bootloader-installer bootloader))
(reboot)))))
#:system system
#:make-disk-image? #t
#:disk-image-size disk-image-size
#:disk-image-format disk-image-format
#:references-graphs inputs))
(define* (system-docker-image os
#:key
(name "guixsd-docker-image")
register-closures?)
"Build a docker image. OS is the desired <operating-system>. NAME is the
base name to use for the output file. When REGISTER-CLOSURES? is not #f,
register the closure of OS with Guix in the resulting Docker image. This only
makes sense when you want to build a GuixSD Docker image that has Guix
installed inside of it. If you don't need Guix (e.g., your GuixSD Docker
image just contains a web server that is started by the Shepherd), then you
should set REGISTER-CLOSURES? to #f."
(define not-config?
(match-lambda
(('guix 'config) #f)
(('guix rest ...) #t)
(('gnu rest ...) #t)
(rest #f)))
(define config
;; (guix config) module for consumption by (guix gcrypt).
(scheme-file "gcrypt-config.scm"
#~(begin
(define-module (guix config)
#:export (%libgcrypt))
;; XXX: Work around <http://bugs.gnu.org/15602>.
(eval-when (expand load eval)
(define %libgcrypt
#+(file-append libgcrypt "/lib/libgcrypt"))))))
(mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
(name -> (string-append name ".tar.gz"))
(graph -> "system-graph"))
(define build
(with-imported-modules `(,@(source-module-closure '((guix docker)
(guix build utils)
(gnu build vm))
#:select? not-config?)
(guix build store-copy)
((guix config) => ,config))
#~(begin
;; Guile-JSON is required by (guix docker).
(add-to-load-path
(string-append #+guile-json "/share/guile/site/"
(effective-version)))
(use-modules (guix docker)
(guix build utils)
(gnu build vm)
(srfi srfi-19)
(guix build store-copy))
(let* ((inputs '#$(append (list tar)
(if register-closures?
(list guix)
'())))
;; This initializer requires elevated privileges that are
;; not normally available in the build environment (e.g.,
;; it needs to create device nodes). In order to obtain
;; such privileges, we run it as root in a VM.
(initialize (root-partition-initializer
#:closures '(#$graph)
#:register-closures? #$register-closures?
#:system-directory #$os-drv
;; De-duplication would fail due to
;; cross-device link errors, so don't do it.
#:deduplicate? #f))
;; Even as root in a VM, the initializer would fail due to
;; lack of privileges if we use a root-directory that is on
;; a file system that is shared with the host (e.g., /tmp).
(root-directory "/guixsd-system-root"))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(mkdir root-directory)
(initialize root-directory)
(build-docker-image
(string-append "/xchg/" #$name) ;; The output file.
(cons* root-directory
(call-with-input-file (string-append "/xchg/" #$graph)
read-reference-graph))
#$os-drv
#:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
#:creation-time (make-time time-utc 0 1)
#:transformations `((,root-directory -> "")))))))
(expression->derivation-in-linux-vm
name
;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp
;; needs to be run by a Guile that can dlopen libgcrypt. The following
;; hack works around that problem by putting the "build" gexp into an
;; executable script (created by program-file) which, when executed, will
;; run using a Guile that supports dlopen. That way, the VM's initrd
;; Guile can just execute it via invoke, without using dlopen. See:
;; https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html
(with-imported-modules `((guix build utils))
#~(begin
(use-modules (guix build utils))
;; If we use execl instead of invoke here, the VM will crash with a
;; kernel panic.
(invoke #$(program-file "build-docker-image" build))))
#:make-disk-image? #f
#:single-file-output? #t
#:references-graphs `((,graph ,os-drv)))))
;;;
;;; VM and disk images.
;;;
(define* (operating-system-uuid os #:optional (type 'dce))
"Compute UUID object with a deterministic \"UUID\" for OS, of the given
TYPE (one of 'iso9660 or 'dce). Return a UUID object."
(if (eq? type 'iso9660)
(let ((pad (compose (cut string-pad <> 2 #\0)
number->string))
(h (hash (operating-system-services os) 3600)))
(bytevector->uuid
(string->iso9660-uuid
(string-append "1970-01-01-"
(pad (hash (operating-system-host-name os) 24)) "-"
(pad (quotient h 60)) "-"
(pad (modulo h 60)) "-"
(pad (hash (operating-system-file-systems os) 100))))
'iso9660))
(bytevector->uuid
(uint-list->bytevector
(list (hash file-system-type
(- (expt 2 32) 1))
(hash (operating-system-host-name os)
(- (expt 2 32) 1))
(hash (operating-system-services os)
(- (expt 2 32) 1))
(hash (operating-system-file-systems os)
(- (expt 2 32) 1)))
(endianness little)
4)
type)))
(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 normalize-label
;; ISO labels are all-caps (case-insensitive), but since
;; 'find-partition-by-label' is case-sensitive, make it all-caps here.
(if (string=? "iso9660" file-system-type)
string-upcase
identity))
(define root-label
;; Volume name of the root file system.
(normalize-label "GuixSD_image"))
(define root-uuid
;; UUID of the root file system, computed in a deterministic fashion.
;; This is what we use to locate the root file system so it has to be
;; different from the user's own file system UUIDs.
(operating-system-uuid os
(if (string=? file-system-type "iso9660")
'iso9660
'dce)))
(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 (operating-system-initrd os)
file-systems
#:volatile-root? #t
rest)))
(bootloader (if (string=? "iso9660" file-system-type)
(bootloader-configuration
(inherit (operating-system-bootloader os))
(bootloader grub-mkrescue-bootloader))
(operating-system-bootloader os)))
;; Force our own root file system.
(file-systems (cons (file-system
(mount-point "/")
(device root-uuid)
(title 'uuid)
(type file-system-type))
file-systems-to-keep)))))
(mlet* %store-monad ((os-drv (operating-system-derivation os))
(bootcfg (operating-system-bootcfg os)))
(if (string=? "iso9660" file-system-type)
(iso9660-image #:name name
#:file-system-label root-label
#:file-system-uuid root-uuid
#:os-drv os-drv
#:register-closures? #t
#:bootcfg-drv bootcfg
#:bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os))
#:inputs `(("system" ,os-drv)
("bootcfg" ,bootcfg)))
(qemu-image #:name name
#:os-drv os-drv
#:bootcfg-drv bootcfg
#:bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os))
#:disk-image-size disk-image-size
#:disk-image-format "raw"
#:file-system-type file-system-type
#:file-system-label root-label
#:file-system-uuid root-uuid
#:copy-inputs? #t
#:register-closures? #t
#:inputs `(("system" ,os-drv)
("bootcfg" ,bootcfg)))))))
(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)))
(define root-uuid
;; UUID of the root file system.
(operating-system-uuid os
(if (string=? file-system-type "iso9660")
'iso9660
'dce)))
(let ((os (operating-system (inherit os)
;; Assume we have an initrd with the whole QEMU shebang.
;; Force our own root file system. Refer to it by UUID so that
;; it works regardless of how the image is used ("qemu -hda",
;; Xen, etc.).
(file-systems (cons (file-system
(mount-point "/")
(device root-uuid)
(title 'uuid)
(type file-system-type))
file-systems-to-keep)))))
(mlet* %store-monad
((os-drv (operating-system-derivation os))
(bootcfg (operating-system-bootcfg os)))
(qemu-image #:os-drv os-drv
#:bootcfg-drv bootcfg
#:bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os))
#:disk-image-size disk-image-size
#:file-system-type file-system-type
#:file-system-uuid root-uuid
#:inputs `(("system" ,os-drv)
("bootcfg" ,bootcfg))
#:copy-inputs? #t))))
;;;
;;; 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 must be ASCII, at most 31-byte long, cannot contain
;; slashes, and cannot start with '_'. Compute an identifier that
;; corresponds to the rules.
(string-append "TAG"
(string-drop (bytevector->base32-string
(sha1 (string->utf8 fs)))
4)))
(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 "trans=virtio,cache=loose")
(check? #f)
(create-mount-point? #t)))))
(define* (virtualized-operating-system os mappings #:optional (full-boot? #f))
"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 "/")
(and (eq? 'device (file-system-title fs))
(string-prefix? "/dev/" source))
;; Labels and UUIDs are necessarily invalid in the VM.
(and (file-system-mount? fs)
(or (eq? 'label (file-system-title fs))
(eq? 'uuid (file-system-title fs))
(uuid? source))))))
(operating-system-file-systems os)))
(define virtual-file-systems
(cons (file-system
(mount-point "/")
(device "/dev/vda1")
(type "ext4"))
(append (map mapping->file-system mappings)
user-file-systems)))
(operating-system (inherit os)
;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware),
;; force the traditional i386/BIOS method.
;; See <https://bugs.gnu.org/28768>.
(bootloader (bootloader-configuration
(bootloader grub-bootloader)
(target "/dev/vda")))
(initrd (lambda (file-systems . rest)
(apply (operating-system-initrd os)
file-systems
#:volatile-root? #t
rest)))
;; Disable swap.
(swap-devices '())
;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
;; since that would lead the bootloader config to look for the kernel and
;; initrd in it.
(file-systems (if full-boot?
virtual-file-systems
(cons
(file-system
(inherit (mapping->file-system %store-mapping))
(needed-for-boot? #t))
virtual-file-systems)))))
(define* (system-qemu-image/shared-store
os
#:key
full-boot?
(disk-image-size (* (if full-boot? 500 30) (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))
(bootcfg (operating-system-bootcfg os)))
;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
;; BOOTCFG 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-drv os-drv
#:bootcfg-drv bootcfg
#:bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os))
#:disk-image-size disk-image-size
#:inputs (if full-boot?
`(("bootcfg" ,bootcfg))
'())
;; 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)
#~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
#$fs #$(file-system->mount-tag fs)))
#~(;; Only enable kvm if we see /dev/kvm exists.
;; This allows users without hardware virtualization to still use these
;; commands.
#$@(if (file-exists? "/dev/kvm")
'("-enable-kvm")
'())
"-no-reboot"
"-net nic,model=virtio"
"-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
"-device" "virtio-rng-pci,rng=guixsd-vm-rng"
#$@(map virtfs-option shared-fs)
"-vga std"
(format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly"
#$image)))
(define* (system-qemu-image/shared-store-script os
#:key
(qemu qemu)
(graphic? #t)
(memory-size 256)
(mappings '())
full-boot?
(disk-image-size
(* (if full-boot? 500 70)
(expt 2 20)))
(options '()))
"Return a derivation that builds a script to run a virtual machine image of
OS that shares its store with the host. The virtual machine runs with
MEMORY-SIZE MiB of memory.
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 full-boot?))
(os-drv (operating-system-derivation os))
(image (system-qemu-image/shared-store
os
#:full-boot? full-boot?
#:disk-image-size disk-image-size)))
(define kernel-arguments
#~(list #$@(if graphic? #~() #~("console=ttyS0"))
#+@(operating-system-kernel-arguments os os-drv "/dev/vda1")))
(define qemu-exec
#~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
#$@(if full-boot?
#~()
#~("-kernel" #$(operating-system-kernel-file os)
"-initrd" #$(file-append os-drv "/initrd")
(format #f "-append ~s"
(string-join #$kernel-arguments " "))))
#$@(common-qemu-options image
(map file-system-mapping-source
(cons %store-mapping mappings)))
"-m " (number->string #$memory-size)
#$@options))
(define builder
#~(call-with-output-file #$output
(lambda (port)
(format port "#!~a~% exec ~a \"$@\"~%"
#$(file-append bash "/bin/sh")
(string-join #$qemu-exec " "))
(chmod port #o555))))
(gexp->derivation "run-vm.sh" builder)))
;;;
;;; High-level abstraction.
;;;
(define-record-type* <virtual-machine> %virtual-machine
make-virtual-machine
virtual-machine?
(operating-system virtual-machine-operating-system) ;<operating-system>
(qemu virtual-machine-qemu ;<package>
(default qemu))
(graphic? virtual-machine-graphic? ;Boolean
(default #f))
(memory-size virtual-machine-memory-size ;integer (MiB)
(default 256))
(disk-image-size virtual-machine-disk-image-size ;integer (bytes)
(default 'guess))
(port-forwardings virtual-machine-port-forwardings ;list of integer pairs
(default '())))
(define-syntax virtual-machine
(syntax-rules ()
"Declare a virtual machine running the specified OS, with the given
options."
((_ os) ;shortcut
(%virtual-machine (operating-system os)))
((_ fields ...)
(%virtual-machine fields ...))))
(define (port-forwardings->qemu-options forwardings)
"Return the QEMU option for the given port FORWARDINGS as a string, where
FORWARDINGS is a list of host-port/guest-port pairs."
(string-join
(map (match-lambda
((host-port . guest-port)
(string-append "hostfwd=tcp::"
(number->string host-port)
"-:" (number->string guest-port))))
forwardings)
","))
(define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
system target)
;; XXX: SYSTEM and TARGET are ignored.
(match vm
(($ <virtual-machine> os qemu graphic? memory-size disk-image-size ())
(system-qemu-image/shared-store-script os
#:qemu qemu
#:graphic? graphic?
#:memory-size memory-size
#:disk-image-size
disk-image-size))
(($ <virtual-machine> os qemu graphic? memory-size disk-image-size
forwardings)
(let ((options
`("-net" ,(string-append
"user,"
(port-forwardings->qemu-options forwardings)))))
(system-qemu-image/shared-store-script os
#:qemu qemu
#:graphic? graphic?
#:memory-size memory-size
#:disk-image-size
disk-image-size
#:options options)))))
;;; vm.scm ends here
View git blame Copy permalink