[jackhill/guix/guix.git] / gnu / system / vm.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@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 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 ((gnu build vm)
                #:select (qemu-command))
  #:use-module (gnu packages base)
  #:use-module (gnu packages bootloaders)
  #: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 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 pam)
  #: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
            virtualized-operating-system
            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-minimal)
                                             (env-vars '())
                                             (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.

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
                                      #:linux linux
                                      #:virtio? #t
                                      #: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))))

              (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
                      #:guile-for-build guile-for-build
                      #:references-graphs references-graphs)))

(define* (qemu-image #:key
                     (name "qemu-image")
                     (system (%current-system))
                     (qemu qemu-minimal)
                     (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
   (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 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))
                         (bootcfg  (operating-system-bootcfg os)))
      (qemu-image #:name name
                  #:os-derivation os-drv
                  #:grub-configuration bootcfg
                  #: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)
                             ("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)))

  (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
                               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))
         (bootcfg     (operating-system-bootcfg os)))
      (qemu-image  #:os-derivation os-drv
                   #:grub-configuration bootcfg
                   #:disk-image-size disk-image-size
                   #:file-system-type file-system-type
                   #:inputs `(("system" ,os-drv)
                              ("bootcfg" ,bootcfg))
                   #: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 #: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)))))
            (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)
    (initrd (lambda (file-systems . rest)
              (apply base-initrd file-systems
                     #:volatile-root? #t
                     #:virtio? #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-derivation os-drv
                #:grub-configuration bootcfg
                #: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"

     #$@(map virtfs-option shared-fs)
     "-vga std"
     (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly"
             #$image)
     "-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 30)
                                                    (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 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)))))

    (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)))

;;; vm.scm ends here
Commit	Line	Data
04086015	1	;;; GNU Guix --- Functional package management for GNU
29824d80	2	;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
944d2b17 CAW	3	;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
944d2b17 CAW	4	;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
07f812c4	5	;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
04086015 LC	6	;;;
	7	;;; This file is part of GNU Guix.
	8	;;;
	9	;;; GNU Guix is free software; you can redistribute it and/or modify it
	10	;;; under the terms of the GNU General Public License as published by
	11	;;; the Free Software Foundation; either version 3 of the License, or (at
	12	;;; your option) any later version.
	13	;;;
	14	;;; GNU Guix is distributed in the hope that it will be useful, but
	15	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	16	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	17	;;; GNU General Public License for more details.
	18	;;;
	19	;;; You should have received a copy of the GNU General Public License
	20	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	21
	22	(define-module (gnu system vm)
93d44bd8	23	#:use-module (guix config)
04086015	24	#:use-module (guix store)
02100028	25	#:use-module (guix gexp)
04086015 LC	26	#:use-module (guix derivations)
04086015 LC	27	#:use-module (guix packages)
d9f0a237	28	#:use-module (guix monads)
fcf63cf8	29	#:use-module (guix records)
239c6e27	30	#:use-module (guix modules)
fcf63cf8	31
548f7a8f	32	#:use-module ((gnu build vm)
66670cf3	33	#:select (qemu-command))
bdb36958	34	#:use-module (gnu packages base)
862e38d5	35	#:use-module (gnu packages bootloaders)
1b89a66e	36	#:use-module (gnu packages guile)
bdb36958	37	#:use-module (gnu packages gawk)
1b89a66e	38	#:use-module (gnu packages bash)
4f62d8d6	39	#:use-module (gnu packages less)
04086015	40	#:use-module (gnu packages qemu)
cc4a2aeb	41	#:use-module (gnu packages disk)
5b16ff09	42	#:use-module (gnu packages zile)
04086015	43	#:use-module (gnu packages linux)
30f25b03	44	#:use-module (gnu packages package-management)
04086015 LC	45	#:use-module ((gnu packages make-bootstrap)
04086015 LC	46	#:select (%guile-static-stripped))
9de46ffb	47	#:use-module (gnu packages admin)
0ded70f3 LC	48
0ded70f3 LC	49	#:use-module (gnu system shadow)
6e828634	50	#:use-module (gnu system pam)
735c6dd7	51	#:use-module (gnu system linux-initrd)
0ded70f3	52	#:use-module (gnu system grub)
c5df1839	53	#:use-module (gnu system file-systems)
033adfe7	54	#:use-module (gnu system)
db4fdc04	55	#:use-module (gnu services)
0ded70f3	56
ca85d7bc	57	#:use-module (srfi srfi-1)
04086015 LC	58	#:use-module (srfi srfi-26)
04086015 LC	59	#:use-module (ice-9 match)
0ded70f3	60
04086015	61	#:export (expression->derivation-in-linux-vm
aedb72fb	62	qemu-image
e9f693d0	63	virtualized-operating-system
fd3bfc44	64	system-qemu-image
fcf63cf8	65
fd3bfc44	66	system-qemu-image/shared-store
1e77fedb LC	67	system-qemu-image/shared-store-script
1e77fedb LC	68	system-disk-image))
04086015 LC	69
	70	\f
	71	;;; Commentary:
	72	;;;
	73	;;; Tools to evaluate build expressions within virtual machines.
	74	;;;
	75	;;; Code:
	76
83bcd0b8 LC	77	(define %linux-vm-file-systems
	78	;; File systems mounted for 'derivation-in-linux-vm'. The store and /xchg
	79	;; directory are shared with the host over 9p.
	80	(list (file-system
	81	(mount-point (%store-prefix))
	82	(device "store")
	83	(type "9p")
	84	(needed-for-boot? #t)
3c05b4bc LC	85	(options "trans=virtio")
3c05b4bc LC	86	(check? #f))
83bcd0b8 LC	87	(file-system
	88	(mount-point "/xchg")
	89	(device "xchg")
	90	(type "9p")
	91	(needed-for-boot? #t)
3c05b4bc LC	92	(options "trans=virtio")
3c05b4bc LC	93	(check? #f))))
83bcd0b8	94
d9f0a237	95	(define* (expression->derivation-in-linux-vm name exp
04086015	96	#:key
2455085a	97	(system (%current-system))
04086015	98	(linux linux-libre)
735c6dd7	99	initrd
06da1a6b	100	(qemu qemu-minimal)
04086015	101	(env-vars '())
04086015 LC	102	(guile-for-build
	103	(%guile-for-build))
	104
	105	(make-disk-image? #f)
ca85d7bc	106	(references-graphs #f)
defa1b9b	107	(memory-size 256)
c4a74364	108	(disk-image-format "qcow2")
04086015 LC	109	(disk-image-size
04086015 LC	110	(* 100 (expt 2 20))))
735c6dd7	111	"Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
1aa0033b	112	derivation). In the virtual machine, EXP has access to all its inputs from the
735c6dd7	113	store; it should put its output files in the `/xchg' directory, which is
defa1b9b LC	114	copied to the derivation's output when the VM terminates. The virtual machine
defa1b9b LC	115	runs with MEMORY-SIZE MiB of memory.
04086015	116
c4a74364 LC	117	When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
	118	DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
	119	return it.
ca85d7bc LC	120
	121	When REFERENCES-GRAPHS is true, it must be a list of file name/store path
	122	pairs, as for `derivation'. The files containing the reference graphs are
	123	made available under the /xchg CIFS share."
d9f0a237	124	(mlet* %store-monad
fd129893	125	((user-builder (gexp->file "builder-in-linux-vm" exp))
02100028	126	(loader (gexp->file "linux-vm-loader"
fd129893	127	#~(primitive-load #$user-builder)))
bdb36958	128	(coreutils -> (canonical-package coreutils))
d4254711	129	(initrd (if initrd ; use the default initrd?
735c6dd7	130	(return initrd)
060238ae	131	(base-initrd %linux-vm-file-systems
0d275f4a	132	#:linux linux
24e0160a	133	#:virtio? #t
6c1df081	134	#:qemu-networking? #t))))
1aa0033b LC	135
	136	(define builder
	137	;; Code that launches the VM that evaluates EXP.
239c6e27 LC	138	(with-imported-modules (source-module-closure '((guix build utils)
239c6e27 LC	139	(gnu build vm)))
4ee96a79 LC	140	#~(begin
	141	(use-modules (guix build utils)
	142	(gnu build vm))
	143
	144	(let ((inputs '#$(list qemu coreutils))
43fe431c DC	145	(linux (string-append #$linux "/"
43fe431c DC	146	#$(system-linux-image-file-name)))
4ee96a79 LC	147	(initrd (string-append #$initrd "/initrd"))
	148	(loader #$loader)
	149	(graphs '#$(match references-graphs
	150	(((graph-files . _) ...) graph-files)
	151	(_ #f))))
	152
	153	(set-path-environment-variable "PATH" '("bin") inputs)
	154
	155	(load-in-linux-vm loader
	156	#:output #$output
	157	#:linux linux #:initrd initrd
	158	#:memory-size #$memory-size
	159	#:make-disk-image? #$make-disk-image?
	160	#:disk-image-format #$disk-image-format
	161	#:disk-image-size #$disk-image-size
	162	#:references-graphs graphs)))))
1aa0033b LC	163
	164	(gexp->derivation name builder
	165	;; TODO: Require the "kvm" feature.
	166	#:system system
	167	#:env-vars env-vars
1aa0033b LC	168	#:guile-for-build guile-for-build
1aa0033b LC	169	#:references-graphs references-graphs)))
d9f0a237 LC	170
d9f0a237 LC	171	(define* (qemu-image #:key
04086015 LC	172	(name "qemu-image")
04086015 LC	173	(system (%current-system))
06da1a6b	174	(qemu qemu-minimal)
04086015	175	(disk-image-size (* 100 (expt 2 20)))
c4a74364	176	(disk-image-format "qcow2")
03ddfaf5	177	(file-system-type "ext4")
ef9fc40d	178	file-system-label
f2c403ea	179	os-derivation
0e2ddecd	180	grub-configuration
150e20dd	181	(register-closures? #t)
150e20dd LC	182	(inputs '())
150e20dd LC	183	copy-inputs?)
c4a74364	184	"Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
ef9fc40d LC	185	'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
ef9fc40d LC	186	Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
f2c403ea LC	187	partition. The returned image is a full disk image that runs OS-DERIVATION,
	188	with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
	189	file (GRUB-CONFIGURATION must be the name of a file in the VM.)
93d44bd8	190
150e20dd LC	191	INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
	192	all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
	193	register INPUTS in the store database of the image so that Guix can be used in
b4140694	194	the image."
b53833b2 LC	195	(expression->derivation-in-linux-vm
b53833b2 LC	196	name
239c6e27 LC	197	(with-imported-modules (source-module-closure '((gnu build vm)
239c6e27 LC	198	(guix build utils)))
fd129893 LC	199	#~(begin
	200	(use-modules (gnu build vm)
	201	(guix build utils))
1aa0033b	202
fd129893 LC	203	(let ((inputs
	204	'#$(append (list qemu parted grub e2fsprogs)
	205	(map canonical-package
	206	(list sed grep coreutils findutils gawk))
	207	(if register-closures? (list guix) '())))
1aa0033b	208
fd129893 LC	209	;; This variable is unused but allows us to add INPUTS-TO-COPY
	210	;; as inputs.
	211	(to-register
	212	'#$(map (match-lambda
	213	((name thing) thing)
	214	((name thing output) `(,thing ,output)))
	215	inputs)))
1aa0033b	216
fd129893	217	(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
1aa0033b	218
fd129893 LC	219	(let* ((graphs '#$(match inputs
	220	(((names . _) ...)
	221	names)))
	222	(initialize (root-partition-initializer
	223	#:closures graphs
	224	#:copy-closures? #$copy-inputs?
	225	#:register-closures? #$register-closures?
	226	#:system-directory #$os-derivation))
	227	(partitions (list (partition
	228	(size #$(- disk-image-size
	229	(* 10 (expt 2 20))))
	230	(label #$file-system-label)
	231	(file-system #$file-system-type)
	232	(bootable? #t)
	233	(initializer initialize)))))
	234	(initialize-hard-disk "/dev/vda"
	235	#:partitions partitions
	236	#:grub.cfg #$grub-configuration)
	237	(reboot)))))
b53833b2 LC	238	#:system system
	239	#:make-disk-image? #t
	240	#:disk-image-size disk-image-size
	241	#:disk-image-format disk-image-format
	242	#:references-graphs inputs))
04086015 LC	243
	244	\f
	245	;;;
1e77fedb	246	;;; VM and disk images.
04086015 LC	247	;;;
04086015 LC	248
1e77fedb LC	249	(define* (system-disk-image os
1e77fedb LC	250	#:key
56ef7fcc	251	(name "disk-image")
1e77fedb LC	252	(file-system-type "ext4")
	253	(disk-image-size (* 900 (expt 2 20)))
	254	(volatile? #t))
	255	"Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
	256	system described by OS. Said image can be copied on a USB stick as is. When
	257	VOLATILE? is true, the root file system is made volatile; this is useful
	258	to USB sticks meant to be read-only."
10ace2c4 LC	259	(define root-label
	260	;; Volume name of the root file system. Since we don't know which device
	261	;; will hold it, we use the volume name to find it (using the UUID would
	262	;; be even better, but somewhat less convenient.)
	263	"gnu-disk-image")
	264
1e77fedb LC	265	(define file-systems-to-keep
	266	(remove (lambda (fs)
	267	(string=? (file-system-mount-point fs) "/"))
	268	(operating-system-file-systems os)))
	269
	270	(let ((os (operating-system (inherit os)
932e1f92	271	;; Since this is meant to be used on real hardware, don't
493c245b LC	272	;; install QEMU networking or anything like that. Assume USB
493c245b LC	273	;; mass storage devices (usb-storage.ko) are available.
52ac153e LC	274	(initrd (lambda (file-systems . rest)
	275	(apply base-initrd file-systems
	276	#:volatile-root? #t
52ac153e	277	rest)))
1e77fedb LC	278
	279	;; Force our own root file system.
	280	(file-systems (cons (file-system
	281	(mount-point "/")
10ace2c4	282	(device root-label)
d4c87617	283	(title 'label)
1e77fedb LC	284	(type file-system-type))
	285	file-systems-to-keep)))))
	286
	287	(mlet* %store-monad ((os-drv (operating-system-derivation os))
c76b3046	288	(bootcfg (operating-system-bootcfg os)))
56ef7fcc	289	(qemu-image #:name name
f2c403ea	290	#:os-derivation os-drv
c76b3046	291	#:grub-configuration bootcfg
1e77fedb LC	292	#:disk-image-size disk-image-size
	293	#:disk-image-format "raw"
	294	#:file-system-type file-system-type
10ace2c4	295	#:file-system-label root-label
1e77fedb LC	296	#:copy-inputs? #t
	297	#:register-closures? #t
	298	#:inputs `(("system" ,os-drv)
07f812c4	299	("bootcfg" ,bootcfg))))))
1e77fedb	300
0b14d1d7	301	(define* (system-qemu-image os
66f23d66 LC	302	#:key
	303	(file-system-type "ext4")
	304	(disk-image-size (* 900 (expt 2 20))))
	305	"Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
	306	of the GNU system as described by OS."
1eeccc2f LC	307	(define file-systems-to-keep
	308	;; Keep only file systems other than root and not normally bound to real
	309	;; devices.
	310	(remove (lambda (fs)
	311	(let ((target (file-system-mount-point fs))
	312	(source (file-system-device fs)))
	313	(or (string=? target "/")
	314	(string-prefix? "/dev/" source))))
	315	(operating-system-file-systems os)))
	316
66f23d66	317	(let ((os (operating-system (inherit os)
e84d8b30	318	;; Use an initrd with the whole QEMU shebang.
52ac153e LC	319	(initrd (lambda (file-systems . rest)
	320	(apply base-initrd file-systems
	321	#:virtio? #t
52ac153e	322	rest)))
e84d8b30	323
1eeccc2f LC	324	;; Force our own root file system.
1eeccc2f LC	325	(file-systems (cons (file-system
66f23d66 LC	326	(mount-point "/")
66f23d66 LC	327	(device "/dev/sda1")
1eeccc2f LC	328	(type file-system-type))
1eeccc2f LC	329	file-systems-to-keep)))))
66f23d66 LC	330	(mlet* %store-monad
66f23d66 LC	331	((os-drv (operating-system-derivation os))
c76b3046	332	(bootcfg (operating-system-bootcfg os)))
f2c403ea	333	(qemu-image #:os-derivation os-drv
c76b3046	334	#:grub-configuration bootcfg
66f23d66 LC	335	#:disk-image-size disk-image-size
66f23d66 LC	336	#:file-system-type file-system-type
b4140694	337	#:inputs `(("system" ,os-drv)
07f812c4	338	("bootcfg" ,bootcfg))
150e20dd	339	#:copy-inputs? #t))))
04086015	340
fcf63cf8 LC	341	\f
	342	;;;
	343	;;; VMs that share file systems with the host.
	344	;;;
	345
96ffa27b LC	346	(define (file-system->mount-tag fs)
	347	"Return a 9p mount tag for host file system FS."
	348	;; QEMU mount tags cannot contain slashes and cannot start with '_'.
	349	;; Compute an identifier that corresponds to the rules.
	350	(string-append "TAG"
	351	(string-map (match-lambda
	352	(#\/ #\_)
	353	(chr chr))
	354	fs)))
	355
fcf63cf8 LC	356	(define (mapping->file-system mapping)
	357	"Return a 9p file system that realizes MAPPING."
	358	(match mapping
	359	(($ <file-system-mapping> source target writable?)
	360	(file-system
	361	(mount-point target)
	362	(device (file-system->mount-tag source))
	363	(type "9p")
	364	(flags (if writable? '() '(read-only)))
	365	(options (string-append "trans=virtio"))
	366	(check? #f)
	367	(create-mount-point? #t)))))
	368
909de139	369	(define* (virtualized-operating-system os mappings #:optional (full-boot? #f))
83bcd0b8	370	"Return an operating system based on OS suitable for use in a virtualized
fcf63cf8 LC	371	environment with the store shared with the host. MAPPINGS is a list of
	372	<file-system-mapping> to realize in the virtualized OS."
	373	(define user-file-systems
	374	;; Remove file systems that conflict with those added below, or that are
	375	;; normally bound to real devices.
	376	(remove (lambda (fs)
	377	(let ((target (file-system-mount-point fs))
	378	(source (file-system-device fs)))
	379	(or (string=? target (%store-prefix))
	380	(string=? target "/")
29824d80 LC	381	(and (eq? 'device (file-system-title fs))
29824d80 LC	382	(string-prefix? "/dev/" source)))))
fcf63cf8 LC	383	(operating-system-file-systems os)))
fcf63cf8 LC	384
909de139 DC	385	(define virtual-file-systems
	386	(cons (file-system
	387	(mount-point "/")
	388	(device "/dev/vda1")
	389	(type "ext4"))
	390
	391	(append (map mapping->file-system mappings)
	392	user-file-systems)))
	393
83bcd0b8	394	(operating-system (inherit os)
52ac153e LC	395	(initrd (lambda (file-systems . rest)
	396	(apply base-initrd file-systems
	397	#:volatile-root? #t
	398	#:virtio? #t
52ac153e	399	rest)))
65fb4515 LC	400
	401	;; Disable swap.
	402	(swap-devices '())
	403
909de139 DC	404	;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
	405	;; since that would lead the bootloader config to look for the kernel and
	406	;; initrd in it.
	407	(file-systems (if full-boot?
	408	virtual-file-systems
	409	(cons
	410	(file-system
	411	(inherit (mapping->file-system %store-mapping))
	412	(needed-for-boot? #t))
	413	virtual-file-systems)))))
83bcd0b8	414
fd3bfc44	415	(define* (system-qemu-image/shared-store
0b14d1d7	416	os
6aa260af LC	417	#:key
6aa260af LC	418	full-boot?
4c0416ae	419	(disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
fd3bfc44	420	"Return a derivation that builds a QEMU image of OS that shares its store
6aa260af LC	421	with the host.
	422
	423	When FULL-BOOT? is true, return an image that does a complete boot sequence,
	424	bootloaded included; thus, make a disk image that contains everything the
	425	bootloader refers to: OS kernel, initrd, bootloader data, etc."
	426	(mlet* %store-monad ((os-drv (operating-system-derivation os))
c76b3046	427	(bootcfg (operating-system-bootcfg os)))
6aa260af	428	;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
07f812c4	429	;; BOOTCFG and all its dependencies, including the output of OS-DRV.
6aa260af LC	430	;; This is more than needed (we only need the kernel, initrd, GRUB for its
6aa260af LC	431	;; font, and the background image), but it's hard to filter that.
f2c403ea	432	(qemu-image #:os-derivation os-drv
c76b3046	433	#:grub-configuration bootcfg
150e20dd	434	#:disk-image-size disk-image-size
6aa260af	435	#:inputs (if full-boot?
07f812c4	436	`(("bootcfg" ,bootcfg))
6aa260af	437	'())
150e20dd LC	438
	439	;; XXX: Passing #t here is too slow, so let it off by default.
	440	#:register-closures? #f
6aa260af	441	#:copy-inputs? full-boot?)))
fd3bfc44	442
96ffa27b LC	443	(define* (common-qemu-options image shared-fs)
	444	"Return the a string-value gexp with the common QEMU options to boot IMAGE,
	445	with '-virtfs' options for the host file systems listed in SHARED-FS."
26a076ed	446
96ffa27b	447	(define (virtfs-option fs)
26a076ed DC	448	#~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
26a076ed DC	449	#$fs #$(file-system->mount-tag fs)))
96ffa27b	450
26a076ed	451	#~(;; Only enable kvm if we see /dev/kvm exists.
944d2b17 CAW	452	;; This allows users without hardware virtualization to still use these
944d2b17 CAW	453	;; commands.
26a076ed DC	454	#$@(if (file-exists? "/dev/kvm")
	455	'("-enable-kvm")
	456	'())
	457
	458	"-no-reboot"
	459	"-net nic,model=virtio"
	460
	461	#$@(map virtfs-option shared-fs)
	462	"-vga std"
	463	(format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly"
	464	#$image)
	465	"-m 256"))
3c1f0e3b	466
ab11f0be LC	467	(define* (system-qemu-image/shared-store-script os
	468	#:key
	469	(qemu qemu)
	470	(graphic? #t)
fcf63cf8	471	(mappings '())
6aa260af LC	472	full-boot?
6aa260af LC	473	(disk-image-size
4c0416ae	474	(* (if full-boot? 500 30)
6aa260af	475	(expt 2 20))))
fd3bfc44	476	"Return a derivation that builds a script to run a virtual machine image of
6aa260af LC	477	OS that shares its store with the host.
6aa260af LC	478
fcf63cf8 LC	479	MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
	480	systems into the guest.
	481
6aa260af LC	482	When FULL-BOOT? is true, the returned script runs everything starting from the
	483	bootloader; otherwise it directly starts the operating system kernel. The
	484	DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
	485	it is mostly useful when FULL-BOOT? is true."
909de139	486	(mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?))
6aa260af LC	487	(os-drv (operating-system-derivation os))
	488	(image (system-qemu-image/shared-store
	489	os
	490	#:full-boot? full-boot?
	491	#:disk-image-size disk-image-size)))
26a076ed	492	(define kernel-arguments
83071b05 DM	493	#~(list #$@(if graphic? #~() #~("console=ttyS0"))
83071b05 DM	494	#+@(operating-system-kernel-arguments os os-drv "/dev/vda1")))
26a076ed DC	495
	496	(define qemu-exec
	497	#~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
	498	#$@(if full-boot?
	499	#~()
	500	#~("-kernel" #$(operating-system-kernel-file os)
	501	"-initrd" #$(file-append os-drv "/initrd")
	502	(format #f "-append ~s"
	503	(string-join #$kernel-arguments " "))))
	504	#$@(common-qemu-options image
	505	(map file-system-mapping-source
	506	(cons %store-mapping mappings)))))
	507
fd3bfc44	508	(define builder
02100028 LC	509	#~(call-with-output-file #$output
02100028 LC	510	(lambda (port)
26a076ed DC	511	(format port "#!~a~% exec ~a \"$@\"~%"
	512	#$(file-append bash "/bin/sh")
	513	(string-join #$qemu-exec " "))
02100028 LC	514	(chmod port #o555))))
	515
	516	(gexp->derivation "run-vm.sh" builder)))
fd3bfc44	517
04086015	518	;;; vm.scm ends here