[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 packages base)
                #:select (%final-inputs))
  #:use-module (gnu packages guile)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages less)
  #:use-module (gnu packages qemu)
  #:use-module (gnu packages parted)
  #:use-module (gnu packages zile)
  #:use-module (gnu packages grub)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages package-management)
  #:use-module ((gnu packages make-bootstrap)
                #:select (%guile-static-stripped))
  #:use-module (gnu packages admin)

  #:use-module (gnu system shadow)
  #:use-module (gnu system linux)
  #:use-module (gnu system linux-initrd)
  #:use-module (gnu system grub)
  #:use-module (gnu system)
  #:use-module (gnu services)

  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)

  #:export (expression->derivation-in-linux-vm
            qemu-image
            system-qemu-image
            system-qemu-image/shared-store
            system-qemu-image/shared-store-script))

\f
;;; Commentary:
;;;
;;; Tools to evaluate build expressions within virtual machines.
;;;
;;; Code:

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

;; An alias to circumvent name clashes.
(define %imported-modules imported-modules)

(define* (expression->derivation-in-linux-vm name exp
                                             #:key
                                             (system (%current-system))
                                             (inputs '())
                                             (linux linux-libre)
                                             initrd
                                             (qemu qemu-headless)
                                             (env-vars '())
                                             (imported-modules
                                              '((guix build vm)
                                                (guix build linux-initrd)
                                                (guix build utils)))
                                             (guile-for-build
                                              (%guile-for-build))

                                             (make-disk-image? #f)
                                             (references-graphs #f)
                                             (memory-size 256)
                                             (disk-image-size
                                              (* 100 (expt 2 20))))
  "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
derivation).  In the virtual machine, EXP has access to all of INPUTS from the
store; it should put its output files in the `/xchg' directory, which is
copied to the derivation's output when the VM terminates.  The virtual machine
runs with MEMORY-SIZE MiB of memory.

When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
DISK-IMAGE-SIZE bytes and return it.

IMPORTED-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."
  ;; FIXME: Add #:modules parameter, for the 'use-modules' form.

  (define input-alist
    (map input->name+output inputs))

  (define builder
    ;; Code that launches the VM that evaluates EXP.
    `(let ()
       (use-modules (guix build utils)
                    (guix build vm))

       (let ((linux   (string-append (assoc-ref %build-inputs "linux")
                                     "/bzImage"))
             (initrd  (string-append (assoc-ref %build-inputs "initrd")
                                     "/initrd"))
             (loader  (assoc-ref %build-inputs "loader"))
             (graphs  ',(match references-graphs
                          (((graph-files . _) ...) graph-files)
                          (_ #f))))

         (set-path-environment-variable "PATH" '("bin")
                                        (map cdr %build-inputs))

         (load-in-linux-vm loader
                           #:output (assoc-ref %outputs "out")
                           #:linux linux #:initrd initrd
                           #:memory-size ,memory-size
                           #:make-disk-image? ,make-disk-image?
                           #:disk-image-size ,disk-image-size
                           #:references-graphs graphs))))

  (mlet* %store-monad
      ((input-alist  (sequence %store-monad input-alist))
       (module-dir   (%imported-modules imported-modules))
       (compiled     (compiled-modules imported-modules))
       (exp* ->      `(let ((%build-inputs ',input-alist))
                        ,exp))
       (user-builder (text-file "builder-in-linux-vm"
                                (object->string 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 -> (car (assoc-ref %final-inputs "coreutils")))
       (initrd       (if initrd                   ; use the default initrd?
                         (return initrd)
                         (qemu-initrd #:guile-modules-in-chroot? #t
                                      #:mounts `((9p "store" ,(%store-prefix))
                                                 (9p "xchg" "/xchg")))))
       (inputs       (lower-inputs `(("qemu" ,qemu)
                                     ("linux" ,linux)
                                     ("initrd" ,initrd)
                                     ("coreutils" ,coreutils)
                                     ("builder" ,user-builder)
                                     ("loader" ,loader)
                                     ,@inputs))))
    (derivation-expression name builder
                           ;; TODO: Require the "kvm" feature.
                           #:system system
                           #:inputs inputs
                           #:env-vars env-vars
                           #:modules (delete-duplicates
                                      `((guix build utils)
                                        (guix build vm)
                                        (guix build linux-initrd)
                                        ,@imported-modules))
                           #:guile-for-build guile-for-build
                           #:references-graphs references-graphs)))

(define* (qemu-image #:key
                     (name "qemu-image")
                     (system (%current-system))
                     (disk-image-size (* 100 (expt 2 20)))
                     grub-configuration
                     (initialize-store? #f)
                     (populate #f)
                     (inputs '())
                     (inputs-to-copy '()))
  "Return a bootable, stand-alone QEMU image.  The returned image is a full
disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.)

INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
into the image being built.  When INITIALIZE-STORE? is true, initialize the
store database in the image so that Guix can be used in the image.

POPULATE is a list of directives stating directories or symlinks to be created
in the disk image partition.  It is evaluated once the image has been
populated with INPUTS-TO-COPY.  It can be used to provide additional files,
such as /etc files."
  (mlet %store-monad
      ((graph (sequence %store-monad
                        (map input->name+output inputs-to-copy))))
   (expression->derivation-in-linux-vm
    "qemu-image"
    `(let ()
       (use-modules (guix build vm)
                    (guix build utils))

       (set-path-environment-variable "PATH" '("bin" "sbin")
                                      (map cdr %build-inputs))

       (let ((graphs ',(match inputs-to-copy
                         (((names . _) ...)
                          names))))
         (initialize-hard-disk #:grub.cfg ,grub-configuration
                               #:closures-to-copy graphs
                               #:disk-image-size ,disk-image-size
                               #:initialize-store? ,initialize-store?
                               #:directives ',populate)
         (reboot)))
    #:system system
    #:inputs `(("parted" ,parted)
               ("grub" ,grub)
               ("e2fsprogs" ,e2fsprogs)

               ;; For shell scripts.
               ("sed" ,(car (assoc-ref %final-inputs "sed")))
               ("grep" ,(car (assoc-ref %final-inputs "grep")))
               ("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
               ("findutils" ,(car (assoc-ref %final-inputs "findutils")))
               ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
               ("util-linux" ,util-linux)

               ,@(if initialize-store?
                     `(("guix" ,guix))
                     '())

               ,@inputs-to-copy)
    #:make-disk-image? #t
    #:disk-image-size disk-image-size
    #:references-graphs graph)))

\f
;;;
;;; Stand-alone VM image.
;;;

(define (operating-system-build-gid os)
  "Return as a monadic value the group id for build users of OS, or #f."
  (anym %store-monad
        (lambda (service)
          (and (equal? '(guix-daemon)
                       (service-provision service))
               (match (service-user-groups service)
                 ((group)
                  (user-group-id group)))))
        (operating-system-services os)))

(define (operating-system-default-contents os)
  "Return a list of directives suitable for 'system-qemu-image' describing the
basic contents of the root file system of OS."
  (define (user-directories user)
    (let ((home (user-account-home-directory user))
          ;; XXX: Deal with automatically allocated ids.
          (uid  (or (user-account-uid user) 0))
          (gid  (or (user-account-gid user) 0))
          (root (string-append "/var/guix/profiles/per-user/"
                               (user-account-name user))))
      `((directory ,root ,uid ,gid)
        (directory ,home ,uid ,gid))))

  (mlet* %store-monad ((os-drv    (operating-system-derivation os))
                       (os-dir -> (derivation->output-path os-drv))
                       (build-gid (operating-system-build-gid os))
                       (profile   (operating-system-profile-directory os)))
    (return `((directory ,(%store-prefix) 0 ,(or build-gid 0))
              (directory "/etc")
              (directory "/var/log")                     ; for dmd
              (directory "/var/run/nscd")
              (directory "/var/guix/gcroots")
              ("/var/guix/gcroots/system" -> ,os-dir)
              (directory "/run")
              ("/run/current-system" -> ,profile)
              (directory "/bin")
              ("/bin/sh" -> "/run/current-system/bin/bash")
              (directory "/tmp")
              (directory "/var/guix/profiles/per-user/root" 0 0)

              (directory "/root" 0 0)             ; an exception
              ,@(append-map user-directories
                            (operating-system-users os))))))

(define* (system-qemu-image os
                            #:key (disk-image-size (* 900 (expt 2 20))))
  "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU
system as described by OS."
  (mlet* %store-monad
      ((os-drv      (operating-system-derivation os))
       (os-dir   -> (derivation->output-path os-drv))
       (grub.cfg -> (string-append os-dir "/grub.cfg"))
       (populate    (operating-system-default-contents os)))
    (qemu-image  #:grub-configuration grub.cfg
                 #:populate populate
                 #:disk-image-size disk-image-size
                 #:initialize-store? #t
                 #:inputs-to-copy `(("system" ,os-drv)))))

(define* (system-qemu-image/shared-store
          os
          #:key (disk-image-size (* 15 (expt 2 20))))
  "Return a derivation that builds a QEMU image of OS that shares its store
with the host."
  (mlet* %store-monad
      ((os-drv      (operating-system-derivation os))
       (os-dir   -> (derivation->output-path os-drv))
       (grub.cfg -> (string-append os-dir "/grub.cfg"))
       (populate    (operating-system-default-contents os)))
    ;; TODO: Initialize the database so Guix can be used in the guest.
    (qemu-image #:grub-configuration grub.cfg
                #:populate populate
                #:disk-image-size disk-image-size)))

(define* (system-qemu-image/shared-store-script
          os
          #:key
          (qemu qemu)
          (graphic? #t))
  "Return a derivation that builds a script to run a virtual machine image of
OS that shares its store with the host."
  (define initrd
    (qemu-initrd #:mounts `((9p "store" ,(%store-prefix)))
                 #:volatile-root? #t))

  (mlet* %store-monad
      ((os ->  (operating-system (inherit os) (initrd initrd)))
       (os-drv (operating-system-derivation os))
       (initrd initrd)
       (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-system-x86_64 -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 " #$initrd "/initrd \
-append \"" #$(if graphic? "" "console=ttyS0 ")
  "--load=" #$os-drv "/boot --root=/dev/vda1\" \
  -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)
9f84f12f	26	#:use-module ((gnu packages base)
7bd9604c	27	#:select (%final-inputs))
1b89a66e LC	28	#:use-module (gnu packages guile)
1b89a66e LC	29	#:use-module (gnu packages bash)
4f62d8d6	30	#:use-module (gnu packages less)
04086015 LC	31	#:use-module (gnu packages qemu)
04086015 LC	32	#:use-module (gnu packages parted)
5b16ff09	33	#:use-module (gnu packages zile)
04086015 LC	34	#:use-module (gnu packages grub)
04086015 LC	35	#:use-module (gnu packages linux)
30f25b03	36	#:use-module (gnu packages package-management)
04086015 LC	37	#:use-module ((gnu packages make-bootstrap)
04086015 LC	38	#:select (%guile-static-stripped))
9de46ffb	39	#:use-module (gnu packages admin)
0ded70f3 LC	40
	41	#:use-module (gnu system shadow)
	42	#:use-module (gnu system linux)
735c6dd7	43	#:use-module (gnu system linux-initrd)
0ded70f3	44	#:use-module (gnu system grub)
033adfe7	45	#:use-module (gnu system)
db4fdc04	46	#:use-module (gnu services)
0ded70f3	47
ca85d7bc	48	#:use-module (srfi srfi-1)
04086015 LC	49	#:use-module (srfi srfi-26)
04086015 LC	50	#:use-module (ice-9 match)
0ded70f3	51
04086015	52	#:export (expression->derivation-in-linux-vm
aedb72fb	53	qemu-image
fd3bfc44 LC	54	system-qemu-image
	55	system-qemu-image/shared-store
	56	system-qemu-image/shared-store-script))
04086015 LC	57
	58	\f
	59	;;; Commentary:
	60	;;;
	61	;;; Tools to evaluate build expressions within virtual machines.
	62	;;;
	63	;;; Code:
	64
ef09fdfb LC	65	(define* (input->name+output tuple #:key (system (%current-system)))
	66	"Return as a monadic value a name/file-name pair corresponding to TUPLE, an
	67	input tuple. The output file name is when building for SYSTEM."
	68	(with-monad %store-monad
	69	(match tuple
	70	((input (? package? package))
	71	(mlet %store-monad ((out (package-file package #:system system)))
	72	(return `(,input . ,out))))
	73	((input (? package? package) sub-drv)
	74	(mlet %store-monad ((out (package-file package
	75	#:output sub-drv
	76	#:system system)))
	77	(return `(,input . ,out))))
	78	((input (? derivation? drv))
	79	(return `(,input . ,(derivation->output-path drv))))
	80	((input (? derivation? drv) sub-drv)
	81	(return `(,input . ,(derivation->output-path drv sub-drv))))
	82	((input (and (? string?) (? store-path?) file))
	83	(return `(,input . ,file))))))
	84
ade5ce7a LC	85	;; An alias to circumvent name clashes.
	86	(define %imported-modules imported-modules)
	87
d9f0a237	88	(define* (expression->derivation-in-linux-vm name exp
04086015	89	#:key
2455085a LC	90	(system (%current-system))
2455085a LC	91	(inputs '())
04086015	92	(linux linux-libre)
735c6dd7	93	initrd
f200b03e	94	(qemu qemu-headless)
04086015	95	(env-vars '())
ade5ce7a LC	96	(imported-modules
	97	'((guix build vm)
	98	(guix build linux-initrd)
	99	(guix build utils)))
04086015 LC	100	(guile-for-build
	101	(%guile-for-build))
	102
	103	(make-disk-image? #f)
ca85d7bc	104	(references-graphs #f)
defa1b9b	105	(memory-size 256)
04086015 LC	106	(disk-image-size
04086015 LC	107	(* 100 (expt 2 20))))
735c6dd7 LC	108	"Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
	109	derivation). In the virtual machine, EXP has access to all of INPUTS from the
	110	store; it should put its output files in the `/xchg' directory, which is
defa1b9b LC	111	copied to the derivation's output when the VM terminates. The virtual machine
defa1b9b LC	112	runs with MEMORY-SIZE MiB of memory.
04086015 LC	113
04086015 LC	114	When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
ca85d7bc LC	115	DISK-IMAGE-SIZE bytes and return it.
ca85d7bc LC	116
ade5ce7a LC	117	IMPORTED-MODULES is the set of modules imported in the execution environment
	118	of EXP.
	119
ca85d7bc LC	120	When REFERENCES-GRAPHS is true, it must be a list of file name/store path
	121	pairs, as for `derivation'. The files containing the reference graphs are
	122	made available under the /xchg CIFS share."
ade5ce7a	123	;; FIXME: Add #:modules parameter, for the 'use-modules' form.
8ab73e91	124
04086015	125	(define input-alist
ef09fdfb	126	(map input->name+output inputs))
04086015 LC	127
	128	(define builder
	129	;; Code that launches the VM that evaluates EXP.
ca85d7bc LC	130	`(let ()
ca85d7bc LC	131	(use-modules (guix build utils)
e1a87b90 LC	132	(guix build vm))
	133
	134	(let ((linux (string-append (assoc-ref %build-inputs "linux")
04086015 LC	135	"/bzImage"))
	136	(initrd (string-append (assoc-ref %build-inputs "initrd")
	137	"/initrd"))
ade5ce7a	138	(loader (assoc-ref %build-inputs "loader"))
e1a87b90 LC	139	(graphs ',(match references-graphs
	140	(((graph-files . _) ...) graph-files)
	141	(_ #f))))
	142
	143	(set-path-environment-variable "PATH" '("bin")
	144	(map cdr %build-inputs))
	145
ade5ce7a	146	(load-in-linux-vm loader
e1a87b90 LC	147	#:output (assoc-ref %outputs "out")
	148	#:linux linux #:initrd initrd
	149	#:memory-size ,memory-size
	150	#:make-disk-image? ,make-disk-image?
	151	#:disk-image-size ,disk-image-size
	152	#:references-graphs graphs))))
04086015	153
d9f0a237 LC	154	(mlet* %store-monad
d9f0a237 LC	155	((input-alist (sequence %store-monad input-alist))
ade5ce7a LC	156	(module-dir (%imported-modules imported-modules))
ade5ce7a LC	157	(compiled (compiled-modules imported-modules))
d9f0a237 LC	158	(exp* -> `(let ((%build-inputs ',input-alist))
	159	,exp))
	160	(user-builder (text-file "builder-in-linux-vm"
	161	(object->string exp*)))
02100028 LC	162	(loader (gexp->file "linux-vm-loader"
	163	#~(begin
	164	(set! %load-path
	165	(cons #$module-dir %load-path))
	166	(set! %load-compiled-path
	167	(cons #$compiled
	168	%load-compiled-path))
	169	(primitive-load #$user-builder))))
d9f0a237	170	(coreutils -> (car (assoc-ref %final-inputs "coreutils")))
d4254711	171	(initrd (if initrd ; use the default initrd?
735c6dd7	172	(return initrd)
f200b03e LC	173	(qemu-initrd #:guile-modules-in-chroot? #t
	174	#:mounts `((9p "store" ,(%store-prefix))
	175	(9p "xchg" "/xchg")))))
d9f0a237 LC	176	(inputs (lower-inputs `(("qemu" ,qemu)
	177	("linux" ,linux)
	178	("initrd" ,initrd)
	179	("coreutils" ,coreutils)
	180	("builder" ,user-builder)
ade5ce7a	181	("loader" ,loader)
d9f0a237	182	,@inputs))))
dd1a5a15	183	(derivation-expression name builder
a7d46f12	184	;; TODO: Require the "kvm" feature.
dd1a5a15 LC	185	#:system system
dd1a5a15 LC	186	#:inputs inputs
d9f0a237 LC	187	#:env-vars env-vars
	188	#:modules (delete-duplicates
	189	`((guix build utils)
e1a87b90	190	(guix build vm)
ade5ce7a LC	191	(guix build linux-initrd)
ade5ce7a LC	192	,@imported-modules))
d9f0a237 LC	193	#:guile-for-build guile-for-build
	194	#:references-graphs references-graphs)))
	195
	196	(define* (qemu-image #:key
04086015 LC	197	(name "qemu-image")
	198	(system (%current-system))
	199	(disk-image-size (* 100 (expt 2 20)))
0e2ddecd	200	grub-configuration
30f25b03	201	(initialize-store? #f)
785859d3	202	(populate #f)
93d44bd8	203	(inputs '())
002e5ba8	204	(inputs-to-copy '()))
1b89a66e	205	"Return a bootable, stand-alone QEMU image. The returned image is a full
0e2ddecd	206	disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
033adfe7	207	configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.)
93d44bd8 LC	208
93d44bd8 LC	209	INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
30f25b03 LC	210	into the image being built. When INITIALIZE-STORE? is true, initialize the
30f25b03 LC	211	store database in the image so that Guix can be used in the image.
785859d3	212
d5d0f286 LC	213	POPULATE is a list of directives stating directories or symlinks to be created
	214	in the disk image partition. It is evaluated once the image has been
	215	populated with INPUTS-TO-COPY. It can be used to provide additional files,
	216	such as /etc files."
d9f0a237 LC	217	(mlet %store-monad
d9f0a237 LC	218	((graph (sequence %store-monad
ef09fdfb	219	(map input->name+output inputs-to-copy))))
d9f0a237 LC	220	(expression->derivation-in-linux-vm
	221	"qemu-image"
	222	`(let ()
55651ff2 LC	223	(use-modules (guix build vm)
	224	(guix build utils))
	225
	226	(set-path-environment-variable "PATH" '("bin" "sbin")
	227	(map cdr %build-inputs))
	228
	229	(let ((graphs ',(match inputs-to-copy
	230	(((names . _) ...)
	231	names))))
	232	(initialize-hard-disk #:grub.cfg ,grub-configuration
	233	#:closures-to-copy graphs
	234	#:disk-image-size ,disk-image-size
	235	#:initialize-store? ,initialize-store?
	236	#:directives ',populate)
	237	(reboot)))
d9f0a237 LC	238	#:system system
	239	#:inputs `(("parted" ,parted)
	240	("grub" ,grub)
	241	("e2fsprogs" ,e2fsprogs)
d9f0a237 LC	242
	243	;; For shell scripts.
	244	("sed" ,(car (assoc-ref %final-inputs "sed")))
	245	("grep" ,(car (assoc-ref %final-inputs "grep")))
	246	("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
	247	("findutils" ,(car (assoc-ref %final-inputs "findutils")))
	248	("gawk" ,(car (assoc-ref %final-inputs "gawk")))
	249	("util-linux" ,util-linux)
	250
	251	,@(if initialize-store?
	252	`(("guix" ,guix))
	253	'())
	254
	255	,@inputs-to-copy)
	256	#:make-disk-image? #t
	257	#:disk-image-size disk-image-size
ade5ce7a	258	#:references-graphs graph)))
04086015 LC	259
	260	\f
	261	;;;
aedb72fb	262	;;; Stand-alone VM image.
04086015 LC	263	;;;
04086015 LC	264
fd3bfc44 LC	265	(define (operating-system-build-gid os)
	266	"Return as a monadic value the group id for build users of OS, or #f."
	267	(anym %store-monad
	268	(lambda (service)
	269	(and (equal? '(guix-daemon)
	270	(service-provision service))
	271	(match (service-user-groups service)
	272	((group)
	273	(user-group-id group)))))
	274	(operating-system-services os)))
	275
	276	(define (operating-system-default-contents os)
	277	"Return a list of directives suitable for 'system-qemu-image' describing the
	278	basic contents of the root file system of OS."
682b6599 LC	279	(define (user-directories user)
	280	(let ((home (user-account-home-directory user))
	281	;; XXX: Deal with automatically allocated ids.
	282	(uid (or (user-account-uid user) 0))
	283	(gid (or (user-account-gid user) 0))
2e4e01ee	284	(root (string-append "/var/guix/profiles/per-user/"
682b6599 LC	285	(user-account-name user))))
	286	`((directory ,root ,uid ,gid)
	287	(directory ,home ,uid ,gid))))
	288
f6a9d048 LC	289	(mlet* %store-monad ((os-drv (operating-system-derivation os))
	290	(os-dir -> (derivation->output-path os-drv))
	291	(build-gid (operating-system-build-gid os))
	292	(profile (operating-system-profile-directory os)))
6f58d582	293	(return `((directory ,(%store-prefix) 0 ,(or build-gid 0))
fd3bfc44 LC	294	(directory "/etc")
	295	(directory "/var/log") ; for dmd
	296	(directory "/var/run/nscd")
2e4e01ee LC	297	(directory "/var/guix/gcroots")
2e4e01ee LC	298	("/var/guix/gcroots/system" -> ,os-dir)
f6a9d048 LC	299	(directory "/run")
	300	("/run/current-system" -> ,profile)
	301	(directory "/bin")
682b6599	302	("/bin/sh" -> "/run/current-system/bin/bash")
fd3bfc44	303	(directory "/tmp")
2e4e01ee	304	(directory "/var/guix/profiles/per-user/root" 0 0)
682b6599	305
ea0e9ce2	306	(directory "/root" 0 0) ; an exception
682b6599 LC	307	,@(append-map user-directories
682b6599 LC	308	(operating-system-users os))))))
fd3bfc44	309
0b14d1d7	310	(define* (system-qemu-image os
22dd0438 LC	311	#:key (disk-image-size (* 900 (expt 2 20))))
	312	"Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU
	313	system as described by OS."
0b8a376b	314	(mlet* %store-monad
033adfe7 LC	315	((os-drv (operating-system-derivation os))
	316	(os-dir -> (derivation->output-path os-drv))
	317	(grub.cfg -> (string-append os-dir "/grub.cfg"))
fd3bfc44	318	(populate (operating-system-default-contents os)))
d9f0a237 LC	319	(qemu-image #:grub-configuration grub.cfg
d9f0a237 LC	320	#:populate populate
22dd0438	321	#:disk-image-size disk-image-size
d9f0a237	322	#:initialize-store? #t
033adfe7	323	#:inputs-to-copy `(("system" ,os-drv)))))
04086015	324
fd3bfc44	325	(define* (system-qemu-image/shared-store
0b14d1d7	326	os
fd3bfc44 LC	327	#:key (disk-image-size (* 15 (expt 2 20))))
	328	"Return a derivation that builds a QEMU image of OS that shares its store
	329	with the host."
	330	(mlet* %store-monad
	331	((os-drv (operating-system-derivation os))
	332	(os-dir -> (derivation->output-path os-drv))
	333	(grub.cfg -> (string-append os-dir "/grub.cfg"))
	334	(populate (operating-system-default-contents os)))
	335	;; TODO: Initialize the database so Guix can be used in the guest.
	336	(qemu-image #:grub-configuration grub.cfg
	337	#:populate populate
	338	#:disk-image-size disk-image-size)))
	339
	340	(define* (system-qemu-image/shared-store-script
0b14d1d7	341	os
fd3bfc44	342	#:key
1f3838ac	343	(qemu qemu)
fd3bfc44 LC	344	(graphic? #t))
	345	"Return a derivation that builds a script to run a virtual machine image of
	346	OS that shares its store with the host."
c47f0d8b LC	347	(define initrd
	348	(qemu-initrd #:mounts `((9p "store" ,(%store-prefix)))
	349	#:volatile-root? #t))
	350
	351	(mlet* %store-monad
	352	((os -> (operating-system (inherit os) (initrd initrd)))
	353	(os-drv (operating-system-derivation os))
	354	(initrd initrd)
	355	(image (system-qemu-image/shared-store os)))
fd3bfc44	356	(define builder
02100028 LC	357	#~(call-with-output-file #$output
	358	(lambda (port)
	359	(display
	360	(string-append "#!" #$bash "/bin/sh
	361	exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=virtio \
	362	-virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \
1f3838ac	363	-net user \
02100028 LC	364	-kernel " #$(operating-system-kernel os) "/bzImage \
	365	-initrd " #$initrd "/initrd \
	366	-append \"" #$(if graphic? "" "console=ttyS0 ")
	367	"--load=" #$os-drv "/boot --root=/dev/vda1\" \
	368	-drive file=" #$image
fd3bfc44	369	",if=virtio,cache=writeback,werror=report,readonly\n")
02100028 LC	370	port)
	371	(chmod port #o555))))
	372
	373	(gexp->derivation "run-vm.sh" builder)))
fd3bfc44	374
04086015	375	;;; vm.scm ends here