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

;;; 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 gexp)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix monads)
  #: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* (input->name+output tuple #:key (system (%current-system)))
  "Return as a monadic value a name/file-name pair corresponding to TUPLE, an
input tuple.  The output file name is when building for SYSTEM."
  (with-monad %store-monad
    (match tuple
      ((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))))))

(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 file-systems)
                                                (guix build utils)
                                                (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
                                      #:virtio? #t
                                      #:qemu-networking? #t
                                      #:guile-modules-in-chroot? #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."
  (mlet %store-monad
      ((graph (sequence %store-monad (map input->name+output inputs))))
   (expression->derivation-in-linux-vm
    name
    #~(begin
        (use-modules (gnu build vm)
                     (guix build utils))

        (let ((inputs
               '#$(append (list qemu parted grub e2fsprogs util-linux)
                          (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-hard-disk "/dev/vda"
                                  #:system-directory #$os-derivation
                                  #:grub.cfg #$grub-configuration
                                  #:closures graphs
                                  #:copy-closures? #$copy-inputs?
                                  #:register-closures? #$register-closures?
                                  #:disk-image-size #$disk-image-size
                                  #:file-system-type #$file-system-type
                                  #:file-system-label #$file-system-label)
            (reboot))))
    #:system system
    #:make-disk-image? #t
    #:disk-image-size disk-image-size
    #:disk-image-format disk-image-format
    #:references-graphs graph)))

\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, but make sure
              ;; USB mass storage devices are available.
              (initrd (cut base-initrd <>
                           #:volatile-root? #t
                           #:extra-modules '("usb-storage.ko")))

              ;; 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 (cut base-initrd <>
                           #:virtio? #t
                           #:qemu-networking? #t))

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

(define (virtualized-operating-system os)
  "Return an operating system based on OS suitable for use in a virtualized
environment with the store shared with the host."
  (operating-system (inherit os)
    (initrd (cut base-initrd <>
                 #:volatile-root? #t
                 #:virtio? #t
                 #:qemu-networking? #t))
    (file-systems (cons* (file-system
                           (mount-point "/")
                           (device "/dev/vda1")
                           (type "ext4"))
                         (file-system
                           (mount-point (%store-prefix))
                           (device "store")
                           (type "9p")
                           (needed-for-boot? #t)
                           (options "trans=virtio")
                           (check? #f))

                         ;; Remove file systems that conflict with those
                         ;; above, 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))))))

(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))
       (grub.cfg    (operating-system-grub.cfg os)))
    (qemu-image #:os-derivation os-drv
                #:grub-configuration grub.cfg
                #:disk-image-size disk-image-size
                #:inputs `(("system" ,os-drv))

                ;; XXX: Passing #t here is too slow, so let it off by default.
                #:register-closures? #f
                #:copy-inputs? #f)))

(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."
  (mlet* %store-monad
      ((os ->  (virtualized-operating-system os))
       (os-drv (operating-system-derivation os))
       (image  (system-qemu-image/shared-store os)))
    (define builder
      #~(call-with-output-file #$output
          (lambda (port)
            (display
             (string-append "#!" #$bash "/bin/sh
exec " #$qemu "/bin/" #$(qemu-command (%current-system))
" -enable-kvm -no-reboot -net nic,model=virtio \
  -virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \
  -net user \
  -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\" \
  -serial stdio \
  -drive file=" #$image
  ",if=virtio,cache=writeback,werror=report,readonly\n")
             port)
            (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
735c6dd7	2	;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
04086015 LC	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (gnu system vm)
93d44bd8	20	#:use-module (guix config)
04086015	21	#:use-module (guix store)
02100028	22	#:use-module (guix gexp)
04086015 LC	23	#:use-module (guix derivations)
04086015 LC	24	#:use-module (guix packages)
d9f0a237	25	#:use-module (guix monads)
548f7a8f	26	#:use-module ((gnu build vm)
66670cf3	27	#:select (qemu-command))
bdb36958	28	#:use-module (gnu packages base)
1b89a66e	29	#:use-module (gnu packages guile)
bdb36958	30	#:use-module (gnu packages gawk)
1b89a66e	31	#:use-module (gnu packages bash)
4f62d8d6	32	#:use-module (gnu packages less)
04086015	33	#:use-module (gnu packages qemu)
cc4a2aeb	34	#:use-module (gnu packages disk)
5b16ff09	35	#:use-module (gnu packages zile)
04086015 LC	36	#:use-module (gnu packages grub)
04086015 LC	37	#:use-module (gnu packages linux)
30f25b03	38	#:use-module (gnu packages package-management)
04086015 LC	39	#:use-module ((gnu packages make-bootstrap)
04086015 LC	40	#:select (%guile-static-stripped))
9de46ffb	41	#:use-module (gnu packages admin)
0ded70f3 LC	42
	43	#:use-module (gnu system shadow)
	44	#:use-module (gnu system linux)
735c6dd7	45	#:use-module (gnu system linux-initrd)
0ded70f3	46	#:use-module (gnu system grub)
c5df1839	47	#:use-module (gnu system file-systems)
033adfe7	48	#:use-module (gnu system)
db4fdc04	49	#:use-module (gnu services)
0ded70f3	50
ca85d7bc	51	#:use-module (srfi srfi-1)
04086015 LC	52	#:use-module (srfi srfi-26)
04086015 LC	53	#:use-module (ice-9 match)
0ded70f3	54
04086015	55	#:export (expression->derivation-in-linux-vm
aedb72fb	56	qemu-image
fd3bfc44 LC	57	system-qemu-image
fd3bfc44 LC	58	system-qemu-image/shared-store
1e77fedb LC	59	system-qemu-image/shared-store-script
1e77fedb LC	60	system-disk-image))
04086015 LC	61
	62	\f
	63	;;; Commentary:
	64	;;;
	65	;;; Tools to evaluate build expressions within virtual machines.
	66	;;;
	67	;;; Code:
	68
ef09fdfb LC	69	(define* (input->name+output tuple #:key (system (%current-system)))
	70	"Return as a monadic value a name/file-name pair corresponding to TUPLE, an
	71	input tuple. The output file name is when building for SYSTEM."
	72	(with-monad %store-monad
	73	(match tuple
	74	((input (? package? package))
	75	(mlet %store-monad ((out (package-file package #:system system)))
	76	(return `(,input . ,out))))
	77	((input (? package? package) sub-drv)
	78	(mlet %store-monad ((out (package-file package
	79	#:output sub-drv
	80	#:system system)))
	81	(return `(,input . ,out))))
	82	((input (? derivation? drv))
	83	(return `(,input . ,(derivation->output-path drv))))
	84	((input (? derivation? drv) sub-drv)
	85	(return `(,input . ,(derivation->output-path drv sub-drv))))
	86	((input (and (? string?) (? store-path?) file))
	87	(return `(,input . ,file))))))
	88
83bcd0b8 LC	89	(define %linux-vm-file-systems
	90	;; File systems mounted for 'derivation-in-linux-vm'. The store and /xchg
	91	;; directory are shared with the host over 9p.
	92	(list (file-system
	93	(mount-point (%store-prefix))
	94	(device "store")
	95	(type "9p")
	96	(needed-for-boot? #t)
3c05b4bc LC	97	(options "trans=virtio")
3c05b4bc LC	98	(check? #f))
83bcd0b8 LC	99	(file-system
	100	(mount-point "/xchg")
	101	(device "xchg")
	102	(type "9p")
	103	(needed-for-boot? #t)
3c05b4bc LC	104	(options "trans=virtio")
3c05b4bc LC	105	(check? #f))))
83bcd0b8	106
d9f0a237	107	(define* (expression->derivation-in-linux-vm name exp
04086015	108	#:key
2455085a	109	(system (%current-system))
04086015	110	(linux linux-libre)
735c6dd7	111	initrd
f200b03e	112	(qemu qemu-headless)
04086015	113	(env-vars '())
1aa0033b	114	(modules
548f7a8f LC	115	'((gnu build vm)
548f7a8f LC	116	(gnu build install)
8a9e21d1	117	(gnu build linux-boot)
e2f4b305	118	(gnu build file-systems)
6fd1a796 LC	119	(guix build utils)
6fd1a796 LC	120	(guix build store-copy)))
04086015 LC	121	(guile-for-build
	122	(%guile-for-build))
	123
	124	(make-disk-image? #f)
ca85d7bc	125	(references-graphs #f)
defa1b9b	126	(memory-size 256)
c4a74364	127	(disk-image-format "qcow2")
04086015 LC	128	(disk-image-size
04086015 LC	129	(* 100 (expt 2 20))))
735c6dd7	130	"Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
1aa0033b	131	derivation). In the virtual machine, EXP has access to all its inputs from the
735c6dd7	132	store; it should put its output files in the `/xchg' directory, which is
defa1b9b LC	133	copied to the derivation's output when the VM terminates. The virtual machine
defa1b9b LC	134	runs with MEMORY-SIZE MiB of memory.
04086015	135
c4a74364 LC	136	When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
	137	DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
	138	return it.
ca85d7bc	139
1aa0033b	140	MODULES is the set of modules imported in the execution environment of EXP.
ade5ce7a	141
ca85d7bc LC	142	When REFERENCES-GRAPHS is true, it must be a list of file name/store path
	143	pairs, as for `derivation'. The files containing the reference graphs are
	144	made available under the /xchg CIFS share."
d9f0a237	145	(mlet* %store-monad
1aa0033b LC	146	((module-dir (imported-modules modules))
	147	(compiled (compiled-modules modules))
	148	(user-builder (gexp->file "builder-in-linux-vm" exp))
02100028 LC	149	(loader (gexp->file "linux-vm-loader"
	150	#~(begin
	151	(set! %load-path
	152	(cons #$module-dir %load-path))
	153	(set! %load-compiled-path
	154	(cons #$compiled
	155	%load-compiled-path))
	156	(primitive-load #$user-builder))))
bdb36958	157	(coreutils -> (canonical-package coreutils))
d4254711	158	(initrd (if initrd ; use the default initrd?
735c6dd7	159	(return initrd)
060238ae	160	(base-initrd %linux-vm-file-systems
24e0160a	161	#:virtio? #t
4fc96187	162	#:qemu-networking? #t
83bcd0b8	163	#:guile-modules-in-chroot? #t))))
1aa0033b LC	164
	165	(define builder
	166	;; Code that launches the VM that evaluates EXP.
	167	#~(begin
	168	(use-modules (guix build utils)
548f7a8f	169	(gnu build vm))
1aa0033b LC	170
	171	(let ((inputs '#$(list qemu coreutils))
	172	(linux (string-append #$linux "/bzImage"))
	173	(initrd (string-append #$initrd "/initrd"))
	174	(loader #$loader)
	175	(graphs '#$(match references-graphs
	176	(((graph-files . _) ...) graph-files)
	177	(_ #f))))
	178
	179	(set-path-environment-variable "PATH" '("bin") inputs)
	180
	181	(load-in-linux-vm loader
	182	#:output #$output
	183	#:linux linux #:initrd initrd
	184	#:memory-size #$memory-size
	185	#:make-disk-image? #$make-disk-image?
c4a74364	186	#:disk-image-format #$disk-image-format
1aa0033b LC	187	#:disk-image-size #$disk-image-size
	188	#:references-graphs graphs))))
	189
	190	(gexp->derivation name builder
	191	;; TODO: Require the "kvm" feature.
	192	#:system system
	193	#:env-vars env-vars
5ce3defe	194	#:modules modules
1aa0033b LC	195	#:guile-for-build guile-for-build
1aa0033b LC	196	#:references-graphs references-graphs)))
d9f0a237 LC	197
d9f0a237 LC	198	(define* (qemu-image #:key
04086015 LC	199	(name "qemu-image")
04086015 LC	200	(system (%current-system))
1aa0033b	201	(qemu qemu-headless)
04086015	202	(disk-image-size (* 100 (expt 2 20)))
c4a74364	203	(disk-image-format "qcow2")
03ddfaf5	204	(file-system-type "ext4")
ef9fc40d	205	file-system-label
f2c403ea	206	os-derivation
0e2ddecd	207	grub-configuration
150e20dd	208	(register-closures? #t)
150e20dd LC	209	(inputs '())
150e20dd LC	210	copy-inputs?)
c4a74364	211	"Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
ef9fc40d LC	212	'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
ef9fc40d LC	213	Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
f2c403ea LC	214	partition. The returned image is a full disk image that runs OS-DERIVATION,
	215	with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
	216	file (GRUB-CONFIGURATION must be the name of a file in the VM.)
93d44bd8	217
150e20dd LC	218	INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
	219	all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
	220	register INPUTS in the store database of the image so that Guix can be used in
b4140694	221	the image."
d9f0a237	222	(mlet %store-monad
150e20dd	223	((graph (sequence %store-monad (map input->name+output inputs))))
d9f0a237	224	(expression->derivation-in-linux-vm
1aa0033b LC	225	name
1aa0033b LC	226	#~(begin
548f7a8f	227	(use-modules (gnu build vm)
1aa0033b LC	228	(guix build utils))
	229
	230	(let ((inputs
	231	'#$(append (list qemu parted grub e2fsprogs util-linux)
bdb36958 LC	232	(map canonical-package
bdb36958 LC	233	(list sed grep coreutils findutils gawk))
150e20dd	234	(if register-closures? (list guix) '())))
1aa0033b LC	235
	236	;; This variable is unused but allows us to add INPUTS-TO-COPY
	237	;; as inputs.
150e20dd	238	(to-register
1aa0033b LC	239	'#$(map (match-lambda
	240	((name thing) thing)
	241	((name thing output) `(,thing ,output)))
150e20dd	242	inputs)))
1aa0033b LC	243
	244	(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
	245
150e20dd	246	(let ((graphs '#$(match inputs
1aa0033b LC	247	(((names . _) ...)
1aa0033b LC	248	names))))
f19c6e5f	249	(initialize-hard-disk "/dev/vda"
f2c403ea	250	#:system-directory #$os-derivation
e38e18ff	251	#:grub.cfg #$grub-configuration
150e20dd LC	252	#:closures graphs
	253	#:copy-closures? #$copy-inputs?
	254	#:register-closures? #$register-closures?
1aa0033b	255	#:disk-image-size #$disk-image-size
ef9fc40d LC	256	#:file-system-type #$file-system-type
ef9fc40d LC	257	#:file-system-label #$file-system-label)
1aa0033b	258	(reboot))))
d9f0a237	259	#:system system
d9f0a237 LC	260	#:make-disk-image? #t
d9f0a237 LC	261	#:disk-image-size disk-image-size
c4a74364	262	#:disk-image-format disk-image-format
ade5ce7a	263	#:references-graphs graph)))
04086015 LC	264
	265	\f
	266	;;;
1e77fedb	267	;;; VM and disk images.
04086015 LC	268	;;;
04086015 LC	269
1e77fedb LC	270	(define* (system-disk-image os
1e77fedb LC	271	#:key
56ef7fcc	272	(name "disk-image")
1e77fedb LC	273	(file-system-type "ext4")
	274	(disk-image-size (* 900 (expt 2 20)))
	275	(volatile? #t))
	276	"Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
	277	system described by OS. Said image can be copied on a USB stick as is. When
	278	VOLATILE? is true, the root file system is made volatile; this is useful
	279	to USB sticks meant to be read-only."
10ace2c4 LC	280	(define root-label
	281	;; Volume name of the root file system. Since we don't know which device
	282	;; will hold it, we use the volume name to find it (using the UUID would
	283	;; be even better, but somewhat less convenient.)
	284	"gnu-disk-image")
	285
1e77fedb LC	286	(define file-systems-to-keep
	287	(remove (lambda (fs)
	288	(string=? (file-system-mount-point fs) "/"))
	289	(operating-system-file-systems os)))
	290
	291	(let ((os (operating-system (inherit os)
932e1f92 LC	292	;; Since this is meant to be used on real hardware, don't
	293	;; install QEMU networking or anything like that, but make sure
	294	;; USB mass storage devices are available.
060238ae	295	(initrd (cut base-initrd <>
932e1f92 LC	296	#:volatile-root? #t
932e1f92 LC	297	#:extra-modules '("usb-storage.ko")))
1e77fedb LC	298
	299	;; Force our own root file system.
	300	(file-systems (cons (file-system
	301	(mount-point "/")
10ace2c4	302	(device root-label)
d4c87617	303	(title 'label)
1e77fedb LC	304	(type file-system-type))
	305	file-systems-to-keep)))))
	306
	307	(mlet* %store-monad ((os-drv (operating-system-derivation os))
	308	(grub.cfg (operating-system-grub.cfg os)))
56ef7fcc	309	(qemu-image #:name name
f2c403ea	310	#:os-derivation os-drv
56ef7fcc	311	#:grub-configuration grub.cfg
1e77fedb LC	312	#:disk-image-size disk-image-size
	313	#:disk-image-format "raw"
	314	#:file-system-type file-system-type
10ace2c4	315	#:file-system-label root-label
1e77fedb LC	316	#:copy-inputs? #t
	317	#:register-closures? #t
	318	#:inputs `(("system" ,os-drv)
	319	("grub.cfg" ,grub.cfg))))))
	320
0b14d1d7	321	(define* (system-qemu-image os
66f23d66 LC	322	#:key
	323	(file-system-type "ext4")
	324	(disk-image-size (* 900 (expt 2 20))))
	325	"Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
	326	of the GNU system as described by OS."
1eeccc2f LC	327	(define file-systems-to-keep
	328	;; Keep only file systems other than root and not normally bound to real
	329	;; devices.
	330	(remove (lambda (fs)
	331	(let ((target (file-system-mount-point fs))
	332	(source (file-system-device fs)))
	333	(or (string=? target "/")
	334	(string-prefix? "/dev/" source))))
	335	(operating-system-file-systems os)))
	336
66f23d66	337	(let ((os (operating-system (inherit os)
e84d8b30 LC	338	;; Use an initrd with the whole QEMU shebang.
	339	(initrd (cut base-initrd <>
	340	#:virtio? #t
	341	#:qemu-networking? #t))
	342
1eeccc2f LC	343	;; Force our own root file system.
1eeccc2f LC	344	(file-systems (cons (file-system
66f23d66 LC	345	(mount-point "/")
66f23d66 LC	346	(device "/dev/sda1")
1eeccc2f LC	347	(type file-system-type))
1eeccc2f LC	348	file-systems-to-keep)))))
66f23d66 LC	349	(mlet* %store-monad
66f23d66 LC	350	((os-drv (operating-system-derivation os))
b4140694	351	(grub.cfg (operating-system-grub.cfg os)))
f2c403ea LC	352	(qemu-image #:os-derivation os-drv
f2c403ea LC	353	#:grub-configuration grub.cfg
66f23d66 LC	354	#:disk-image-size disk-image-size
66f23d66 LC	355	#:file-system-type file-system-type
b4140694 LC	356	#:inputs `(("system" ,os-drv)
b4140694 LC	357	("grub.cfg" ,grub.cfg))
150e20dd	358	#:copy-inputs? #t))))
04086015	359
83bcd0b8 LC	360	(define (virtualized-operating-system os)
	361	"Return an operating system based on OS suitable for use in a virtualized
	362	environment with the store shared with the host."
	363	(operating-system (inherit os)
060238ae	364	(initrd (cut base-initrd <>
24e0160a	365	#:volatile-root? #t
4fc96187 LC	366	#:virtio? #t
4fc96187 LC	367	#:qemu-networking? #t))
1eeccc2f LC	368	(file-systems (cons* (file-system
	369	(mount-point "/")
	370	(device "/dev/vda1")
	371	(type "ext4"))
	372	(file-system
	373	(mount-point (%store-prefix))
	374	(device "store")
	375	(type "9p")
	376	(needed-for-boot? #t)
	377	(options "trans=virtio")
	378	(check? #f))
	379
	380	;; Remove file systems that conflict with those
	381	;; above, or that are normally bound to real devices.
	382	(remove (lambda (fs)
	383	(let ((target (file-system-mount-point fs))
	384	(source (file-system-device fs)))
	385	(or (string=? target (%store-prefix))
	386	(string=? target "/")
	387	(string-prefix? "/dev/" source))))
	388	(operating-system-file-systems os))))))
83bcd0b8	389
fd3bfc44	390	(define* (system-qemu-image/shared-store
0b14d1d7	391	os
fd3bfc44 LC	392	#:key (disk-image-size (* 15 (expt 2 20))))
	393	"Return a derivation that builds a QEMU image of OS that shares its store
	394	with the host."
	395	(mlet* %store-monad
	396	((os-drv (operating-system-derivation os))
b4140694	397	(grub.cfg (operating-system-grub.cfg os)))
f2c403ea LC	398	(qemu-image #:os-derivation os-drv
f2c403ea LC	399	#:grub-configuration grub.cfg
150e20dd LC	400	#:disk-image-size disk-image-size
	401	#:inputs `(("system" ,os-drv))
	402
	403	;; XXX: Passing #t here is too slow, so let it off by default.
	404	#:register-closures? #f
	405	#:copy-inputs? #f)))
fd3bfc44 LC	406
fd3bfc44 LC	407	(define* (system-qemu-image/shared-store-script
0b14d1d7	408	os
fd3bfc44	409	#:key
1f3838ac	410	(qemu qemu)
fd3bfc44 LC	411	(graphic? #t))
	412	"Return a derivation that builds a script to run a virtual machine image of
	413	OS that shares its store with the host."
c47f0d8b	414	(mlet* %store-monad
83bcd0b8	415	((os -> (virtualized-operating-system os))
c47f0d8b	416	(os-drv (operating-system-derivation os))
c47f0d8b	417	(image (system-qemu-image/shared-store os)))
fd3bfc44	418	(define builder
02100028 LC	419	#~(call-with-output-file #$output
	420	(lambda (port)
	421	(display
	422	(string-append "#!" #$bash "/bin/sh
66670cf3 LC	423	exec " #$qemu "/bin/" #$(qemu-command (%current-system))
66670cf3 LC	424	" -enable-kvm -no-reboot -net nic,model=virtio \
02100028	425	-virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \
1f3838ac	426	-net user \
02100028	427	-kernel " #$(operating-system-kernel os) "/bzImage \
83bcd0b8	428	-initrd " #$os-drv "/initrd \
02100028	429	-append \"" #$(if graphic? "" "console=ttyS0 ")
b4140694	430	"--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1\" \
5a84a6c3	431	-serial stdio \
02100028	432	-drive file=" #$image
fd3bfc44	433	",if=virtio,cache=writeback,werror=report,readonly\n")
02100028 LC	434	port)
	435	(chmod port #o555))))
	436
	437	(gexp->derivation "run-vm.sh" builder)))
fd3bfc44	438
04086015	439	;;; vm.scm ends here