gnu/system/vm.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
   4 ;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
   5 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   6 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (gnu system vm)
  24   #:use-module (guix config)
  25   #:use-module (guix store)
  26   #:use-module (guix gexp)
  27   #:use-module (guix derivations)
  28   #:use-module (guix packages)
  29   #:use-module (guix monads)
  30   #:use-module (guix records)
  31   #:use-module (guix modules)
  32
  33   #:use-module ((gnu build vm)
  34                 #:select (qemu-command))
  35   #:use-module (gnu packages base)
  36   #:use-module (gnu packages bootloaders)
  37   #:use-module (gnu packages cdrom)
  38   #:use-module (gnu packages guile)
  39   #:use-module (gnu packages gawk)
  40   #:use-module (gnu packages bash)
  41   #:use-module (gnu packages less)
  42   #:use-module (gnu packages virtualization)
  43   #:use-module (gnu packages disk)
  44   #:use-module (gnu packages zile)
  45   #:use-module (gnu packages linux)
  46   #:use-module (gnu packages package-management)
  47   #:use-module ((gnu packages make-bootstrap)
  48                 #:select (%guile-static-stripped))
  49   #:use-module (gnu packages admin)
  50
  51   #:use-module (gnu bootloader)
  52   #:use-module ((gnu bootloader grub) #:select (grub-mkrescue-bootloader))
  53   #:use-module (gnu system shadow)
  54   #:use-module (gnu system pam)
  55   #:use-module (gnu system linux-initrd)
  56   #:use-module (gnu bootloader)
  57   #:use-module (gnu system file-systems)
  58   #:use-module (gnu system)
  59   #:use-module (gnu services)
  60
  61   #:use-module (srfi srfi-1)
  62   #:use-module (srfi srfi-26)
  63   #:use-module (ice-9 match)
  64
  65   #:export (expression->derivation-in-linux-vm
  66             qemu-image
  67             virtualized-operating-system
  68             system-qemu-image
  69
  70             system-qemu-image/shared-store
  71             system-qemu-image/shared-store-script
  72             system-disk-image
  73
  74             virtual-machine
  75             virtual-machine?))
  76
  77 \f
  78 ;;; Commentary:
  79 ;;;
  80 ;;; Tools to evaluate build expressions within virtual machines.
  81 ;;;
  82 ;;; Code:
  83
  84 (define %linux-vm-file-systems
  85   ;; File systems mounted for 'derivation-in-linux-vm'.  The store and /xchg
  86   ;; directory are shared with the host over 9p.
  87   (list (file-system
  88           (mount-point (%store-prefix))
  89           (device "store")
  90           (type "9p")
  91           (needed-for-boot? #t)
  92           (options "trans=virtio")
  93           (check? #f))
  94         (file-system
  95           (mount-point "/xchg")
  96           (device "xchg")
  97           (type "9p")
  98           (needed-for-boot? #t)
  99           (options "trans=virtio")
 100           (check? #f))))
 101
 102 (define* (expression->derivation-in-linux-vm name exp
 103                                              #:key
 104                                              (system (%current-system))
 105                                              (linux linux-libre)
 106                                              initrd
 107                                              (qemu qemu-minimal)
 108                                              (env-vars '())
 109                                              (guile-for-build
 110                                               (%guile-for-build))
 111
 112                                              (single-file-output? #f)
 113                                              (make-disk-image? #f)
 114                                              (references-graphs #f)
 115                                              (memory-size 256)
 116                                              (disk-image-format "qcow2")
 117                                              (disk-image-size 'guess))
 118   "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
 119 derivation).  The virtual machine runs with MEMORY-SIZE MiB of memory.  In the
 120 virtual machine, EXP has access to all its inputs from the store; it should
 121 put its output file(s) in the '/xchg' directory.
 122
 123 If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
 124 Otherwise, copy the contents of /xchg to a new directory OUTPUT.
 125
 126 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
 127 DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
 128 return it.  When DISK-IMAGE-SIZE is 'guess, estimate the image size based
 129 based on the size of the closure of REFERENCES-GRAPHS.
 130
 131 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 132 pairs, as for `derivation'.  The files containing the reference graphs are
 133 made available under the /xchg CIFS share."
 134   (mlet* %store-monad
 135       ((user-builder (gexp->file "builder-in-linux-vm" exp))
 136        (loader       (gexp->file "linux-vm-loader"
 137                                  #~(primitive-load #$user-builder)))
 138        (coreutils -> (canonical-package coreutils))
 139        (initrd       (if initrd                   ; use the default initrd?
 140                          (return initrd)
 141                          (base-initrd %linux-vm-file-systems
 142                                       #:linux linux
 143                                       #:virtio? #t
 144                                       #:qemu-networking? #t))))
 145
 146     (define builder
 147       ;; Code that launches the VM that evaluates EXP.
 148       (with-imported-modules (source-module-closure '((guix build utils)
 149                                                       (gnu build vm)))
 150         #~(begin
 151             (use-modules (guix build utils)
 152                          (gnu build vm))
 153
 154             (let* ((inputs  '#$(list qemu coreutils))
 155                    (linux   (string-append #$linux "/"
 156                                            #$(system-linux-image-file-name)))
 157                    (initrd  (string-append #$initrd "/initrd"))
 158                    (loader  #$loader)
 159                    (graphs  '#$(match references-graphs
 160                                  (((graph-files . _) ...) graph-files)
 161                                  (_ #f)))
 162                    (size    #$(if (eq? 'guess disk-image-size)
 163                                   #~(+ (* 70 (expt 2 20)) ;ESP
 164                                        (estimated-partition-size graphs))
 165                                   disk-image-size)))
 166
 167               (set-path-environment-variable "PATH" '("bin") inputs)
 168
 169               (load-in-linux-vm loader
 170                                 #:output #$output
 171                                 #:linux linux #:initrd initrd
 172                                 #:memory-size #$memory-size
 173                                 #:make-disk-image? #$make-disk-image?
 174                                 #:single-file-output? #$single-file-output?
 175                                 #:disk-image-format #$disk-image-format
 176                                 #:disk-image-size size
 177                                 #:references-graphs graphs)))))
 178
 179     (gexp->derivation name builder
 180                       ;; TODO: Require the "kvm" feature.
 181                       #:system system
 182                       #:env-vars env-vars
 183                       #:guile-for-build guile-for-build
 184                       #:references-graphs references-graphs)))
 185
 186 (define* (iso9660-image #:key
 187                         (name "iso9660-image")
 188                         file-system-label
 189                         file-system-uuid
 190                         (system (%current-system))
 191                         (qemu qemu-minimal)
 192                         os-drv
 193                         bootcfg-drv
 194                         bootloader
 195                         register-closures?
 196                         (inputs '()))
 197   "Return a bootable, stand-alone iso9660 image.
 198
 199 INPUTS is a list of inputs (as for packages)."
 200   (expression->derivation-in-linux-vm
 201    name
 202    (with-imported-modules (source-module-closure '((gnu build vm)
 203                                                    (guix build utils)))
 204      #~(begin
 205          (use-modules (gnu build vm)
 206                       (guix build utils))
 207
 208          (let ((inputs
 209                 '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
 210                            (map canonical-package
 211                                 (list sed grep coreutils findutils gawk))
 212                            (if register-closures? (list guix) '())))
 213
 214
 215                (graphs     '#$(match inputs
 216                                    (((names . _) ...)
 217                                     names)))
 218                ;; This variable is unused but allows us to add INPUTS-TO-COPY
 219                ;; as inputs.
 220                (to-register
 221                 '#$(map (match-lambda
 222                           ((name thing) thing)
 223                           ((name thing output) `(,thing ,output)))
 224                         inputs)))
 225
 226            (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 227            (make-iso9660-image #$(bootloader-package bootloader)
 228                                #$bootcfg-drv
 229                                #$os-drv
 230                                "/xchg/guixsd.iso"
 231                                #:register-closures? #$register-closures?
 232                                #:closures graphs
 233                                #:volume-id #$file-system-label
 234                                #:volume-uuid #$file-system-uuid)
 235            (reboot))))
 236    #:system system
 237    #:make-disk-image? #f
 238    #:single-file-output? #t
 239    #:references-graphs inputs))
 240
 241 (define* (qemu-image #:key
 242                      (name "qemu-image")
 243                      (system (%current-system))
 244                      (qemu qemu-minimal)
 245                      (disk-image-size 'guess)
 246                      (disk-image-format "qcow2")
 247                      (file-system-type "ext4")
 248                      file-system-label
 249                      os-drv
 250                      bootcfg-drv
 251                      bootloader
 252                      (register-closures? #t)
 253                      (inputs '())
 254                      copy-inputs?)
 255   "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
 256 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
 257 Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
 258 partition.  The returned image is a full disk image that runs OS-DERIVATION,
 259 with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
 260 file (GRUB-CONFIGURATION must be the name of a file in the VM.)
 261
 262 INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 263 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
 264 register INPUTS in the store database of the image so that Guix can be used in
 265 the image."
 266   (expression->derivation-in-linux-vm
 267    name
 268    (with-imported-modules (source-module-closure '((gnu build vm)
 269                                                    (guix build utils)))
 270      #~(begin
 271          (use-modules (gnu build vm)
 272                       (guix build utils)
 273                       (srfi srfi-26))
 274
 275          (let ((inputs
 276                 '#$(append (list qemu parted e2fsprogs dosfstools)
 277                            (map canonical-package
 278                                 (list sed grep coreutils findutils gawk))
 279                            (if register-closures? (list guix) '())))
 280
 281                ;; This variable is unused but allows us to add INPUTS-TO-COPY
 282                ;; as inputs.
 283                (to-register
 284                 '#$(map (match-lambda
 285                           ((name thing) thing)
 286                           ((name thing output) `(,thing ,output)))
 287                         inputs)))
 288
 289            (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 290
 291            (let* ((graphs     '#$(match inputs
 292                                    (((names . _) ...)
 293                                     names)))
 294                   (initialize (root-partition-initializer
 295                                #:closures graphs
 296                                #:copy-closures? #$copy-inputs?
 297                                #:register-closures? #$register-closures?
 298                                #:system-directory #$os-drv))
 299                   (root-size  #$(if (eq? 'guess disk-image-size)
 300                                     #~(estimated-partition-size
 301                                        (map (cut string-append "/xchg/" <>)
 302                                             graphs))
 303                                     (- disk-image-size
 304                                        (* 50 (expt 2 20)))))
 305                   (partitions (list (partition
 306                                      (size root-size)
 307                                      (label #$file-system-label)
 308                                      (file-system #$file-system-type)
 309                                      (flags '(boot))
 310                                      (initializer initialize))
 311                                     ;; Append a small EFI System Partition for
 312                                     ;; use with UEFI bootloaders.
 313                                     (partition
 314                                      ;; The standalone grub image is about 10MiB, but
 315                                      ;; leave some room for custom or multiple images.
 316                                      (size (* 40 (expt 2 20)))
 317                                      (label "GNU-ESP")             ;cosmetic only
 318                                      ;; Use "vfat" here since this property is used
 319                                      ;; when mounting. The actual FAT-ness is based
 320                                      ;; on filesystem size (16 in this case).
 321                                      (file-system "vfat")
 322                                      (flags '(esp))))))
 323              (initialize-hard-disk "/dev/vda"
 324                                    #:partitions partitions
 325                                    #:grub-efi #$grub-efi
 326                                    #:bootloader-package
 327                                    #$(bootloader-package bootloader)
 328                                    #:bootcfg #$bootcfg-drv
 329                                    #:bootcfg-location
 330                                    #$(bootloader-configuration-file bootloader)
 331                                    #:bootloader-installer
 332                                    #$(bootloader-installer bootloader))
 333              (reboot)))))
 334    #:system system
 335    #:make-disk-image? #t
 336    #:disk-image-size disk-image-size
 337    #:disk-image-format disk-image-format
 338    #:references-graphs inputs))
 339
 340 \f
 341 ;;;
 342 ;;; VM and disk images.
 343 ;;;
 344
 345 (define* (system-disk-image os
 346                             #:key
 347                             (name "disk-image")
 348                             (file-system-type "ext4")
 349                             (disk-image-size (* 900 (expt 2 20)))
 350                             (volatile? #t))
 351   "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
 352 system described by OS.  Said image can be copied on a USB stick as is.  When
 353 VOLATILE? is true, the root file system is made volatile; this is useful
 354 to USB sticks meant to be read-only."
 355   (define normalize-label
 356     ;; ISO labels are all-caps (case-insensitive), but since
 357     ;; 'find-partition-by-label' is case-sensitive, make it all-caps here.
 358     (if (string=? "iso9660" file-system-type)
 359         string-upcase
 360         identity))
 361   (define root-label
 362     ;; Volume name of the root file system.  Since we don't know which device
 363     ;; will hold it, we use the volume name to find it (using the UUID would
 364     ;; be even better, but somewhat less convenient.)
 365     (normalize-label "GuixSD_image"))
 366
 367   (define file-systems-to-keep
 368     (remove (lambda (fs)
 369               (string=? (file-system-mount-point fs) "/"))
 370             (operating-system-file-systems os)))
 371
 372   (let ((os (operating-system (inherit os)
 373               ;; Since this is meant to be used on real hardware, don't
 374               ;; install QEMU networking or anything like that.  Assume USB
 375               ;; mass storage devices (usb-storage.ko) are available.
 376               (initrd (lambda (file-systems . rest)
 377                         (apply base-initrd file-systems
 378                                #:volatile-root? #t
 379                                rest)))
 380
 381               (bootloader (if (string=? "iso9660" file-system-type)
 382                               (bootloader-configuration
 383                                 (inherit (operating-system-bootloader os))
 384                                 (bootloader grub-mkrescue-bootloader))
 385                               (operating-system-bootloader os)))
 386
 387               ;; Force our own root file system.
 388               (file-systems (cons (file-system
 389                                     (mount-point "/")
 390                                     (device root-label)
 391                                     (title 'label)
 392                                     (type file-system-type))
 393                                   file-systems-to-keep)))))
 394
 395     (mlet* %store-monad ((os-drv   (operating-system-derivation os))
 396                          (bootcfg  (operating-system-bootcfg os)))
 397       (if (string=? "iso9660" file-system-type)
 398           (iso9660-image #:name name
 399                          #:file-system-label root-label
 400                          #:file-system-uuid #f
 401                          #:os-drv os-drv
 402                          #:bootcfg-drv bootcfg
 403                          #:bootloader (bootloader-configuration-bootloader
 404                                         (operating-system-bootloader os))
 405                          #:inputs `(("system" ,os-drv)
 406                                     ("bootcfg" ,bootcfg)))
 407           (qemu-image #:name name
 408                       #:os-drv os-drv
 409                       #:bootcfg-drv bootcfg
 410                       #:bootloader (bootloader-configuration-bootloader
 411                                     (operating-system-bootloader os))
 412                       #:disk-image-size disk-image-size
 413                       #:disk-image-format "raw"
 414                       #:file-system-type file-system-type
 415                       #:file-system-label root-label
 416                       #:copy-inputs? #t
 417                       #:register-closures? #t
 418                       #:inputs `(("system" ,os-drv)
 419                                  ("bootcfg" ,bootcfg)))))))
 420
 421 (define* (system-qemu-image os
 422                             #:key
 423                             (file-system-type "ext4")
 424                             (disk-image-size (* 900 (expt 2 20))))
 425   "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
 426 of the GNU system as described by OS."
 427   (define file-systems-to-keep
 428     ;; Keep only file systems other than root and not normally bound to real
 429     ;; devices.
 430     (remove (lambda (fs)
 431               (let ((target (file-system-mount-point fs))
 432                     (source (file-system-device fs)))
 433                 (or (string=? target "/")
 434                     (string-prefix? "/dev/" source))))
 435             (operating-system-file-systems os)))
 436
 437   (let ((os (operating-system (inherit os)
 438               ;; Use an initrd with the whole QEMU shebang.
 439               (initrd (lambda (file-systems . rest)
 440                         (apply base-initrd file-systems
 441                                #:virtio? #t
 442                                rest)))
 443
 444               ;; Force our own root file system.
 445               (file-systems (cons (file-system
 446                                     (mount-point "/")
 447                                     (device "/dev/sda1")
 448                                     (type file-system-type))
 449                                   file-systems-to-keep)))))
 450     (mlet* %store-monad
 451         ((os-drv      (operating-system-derivation os))
 452          (bootcfg     (operating-system-bootcfg os)))
 453       (qemu-image  #:os-drv os-drv
 454                    #:bootcfg-drv bootcfg
 455                    #:bootloader (bootloader-configuration-bootloader
 456                                  (operating-system-bootloader os))
 457                    #:disk-image-size disk-image-size
 458                    #:file-system-type file-system-type
 459                    #:inputs `(("system" ,os-drv)
 460                               ("bootcfg" ,bootcfg))
 461                    #:copy-inputs? #t))))
 462
 463 \f
 464 ;;;
 465 ;;; VMs that share file systems with the host.
 466 ;;;
 467
 468 (define (file-system->mount-tag fs)
 469   "Return a 9p mount tag for host file system FS."
 470   ;; QEMU mount tags cannot contain slashes and cannot start with '_'.
 471   ;; Compute an identifier that corresponds to the rules.
 472   (string-append "TAG"
 473                  (string-map (match-lambda
 474                               (#\/ #\_)
 475                               (chr chr))
 476                              fs)))
 477
 478 (define (mapping->file-system mapping)
 479   "Return a 9p file system that realizes MAPPING."
 480   (match mapping
 481     (($ <file-system-mapping> source target writable?)
 482      (file-system
 483        (mount-point target)
 484        (device (file-system->mount-tag source))
 485        (type "9p")
 486        (flags (if writable? '() '(read-only)))
 487        (options (string-append "trans=virtio"))
 488        (check? #f)
 489        (create-mount-point? #t)))))
 490
 491 (define* (virtualized-operating-system os mappings #:optional (full-boot? #f))
 492   "Return an operating system based on OS suitable for use in a virtualized
 493 environment with the store shared with the host.  MAPPINGS is a list of
 494 <file-system-mapping> to realize in the virtualized OS."
 495   (define user-file-systems
 496     ;; Remove file systems that conflict with those added below, or that are
 497     ;; normally bound to real devices.
 498     (remove (lambda (fs)
 499               (let ((target (file-system-mount-point fs))
 500                     (source (file-system-device fs)))
 501                 (or (string=? target (%store-prefix))
 502                     (string=? target "/")
 503                     (and (eq? 'device (file-system-title fs))
 504                          (string-prefix? "/dev/" source)))))
 505             (operating-system-file-systems os)))
 506
 507   (define virtual-file-systems
 508     (cons (file-system
 509             (mount-point "/")
 510             (device "/dev/vda1")
 511             (type "ext4"))
 512
 513           (append (map mapping->file-system mappings)
 514                   user-file-systems)))
 515
 516   (operating-system (inherit os)
 517     (initrd (lambda (file-systems . rest)
 518               (apply base-initrd file-systems
 519                      #:volatile-root? #t
 520                      #:virtio? #t
 521                      rest)))
 522
 523     ;; Disable swap.
 524     (swap-devices '())
 525
 526     ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
 527     ;; since that would lead the bootloader config to look for the kernel and
 528     ;; initrd in it.
 529     (file-systems (if full-boot?
 530                       virtual-file-systems
 531                       (cons
 532                        (file-system
 533                          (inherit (mapping->file-system %store-mapping))
 534                          (needed-for-boot? #t))
 535                        virtual-file-systems)))))
 536
 537 (define* (system-qemu-image/shared-store
 538           os
 539           #:key
 540           full-boot?
 541           (disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
 542   "Return a derivation that builds a QEMU image of OS that shares its store
 543 with the host.
 544
 545 When FULL-BOOT? is true, return an image that does a complete boot sequence,
 546 bootloaded included; thus, make a disk image that contains everything the
 547 bootloader refers to: OS kernel, initrd, bootloader data, etc."
 548   (mlet* %store-monad ((os-drv   (operating-system-derivation os))
 549                        (bootcfg  (operating-system-bootcfg os)))
 550     ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
 551     ;; BOOTCFG and all its dependencies, including the output of OS-DRV.
 552     ;; This is more than needed (we only need the kernel, initrd, GRUB for its
 553     ;; font, and the background image), but it's hard to filter that.
 554     (qemu-image #:os-drv os-drv
 555                 #:bootcfg-drv bootcfg
 556                 #:bootloader (bootloader-configuration-bootloader
 557                               (operating-system-bootloader os))
 558                 #:disk-image-size disk-image-size
 559                 #:inputs (if full-boot?
 560                              `(("bootcfg" ,bootcfg))
 561                              '())
 562
 563                 ;; XXX: Passing #t here is too slow, so let it off by default.
 564                 #:register-closures? #f
 565                 #:copy-inputs? full-boot?)))
 566
 567 (define* (common-qemu-options image shared-fs)
 568   "Return the a string-value gexp with the common QEMU options to boot IMAGE,
 569 with '-virtfs' options for the host file systems listed in SHARED-FS."
 570
 571   (define (virtfs-option fs)
 572     #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
 573               #$fs #$(file-system->mount-tag fs)))
 574
 575   #~(;; Only enable kvm if we see /dev/kvm exists.
 576      ;; This allows users without hardware virtualization to still use these
 577      ;; commands.
 578      #$@(if (file-exists? "/dev/kvm")
 579             '("-enable-kvm")
 580             '())
 581
 582      "-no-reboot"
 583      "-net nic,model=virtio"
 584
 585      #$@(map virtfs-option shared-fs)
 586      "-vga std"
 587      (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly"
 588              #$image)))
 589
 590 (define* (system-qemu-image/shared-store-script os
 591                                                 #:key
 592                                                 (qemu qemu)
 593                                                 (graphic? #t)
 594                                                 (memory-size 256)
 595                                                 (mappings '())
 596                                                 full-boot?
 597                                                 (disk-image-size
 598                                                  (* (if full-boot? 500 70)
 599                                                     (expt 2 20)))
 600                                                 (options '()))
 601   "Return a derivation that builds a script to run a virtual machine image of
 602 OS that shares its store with the host.  The virtual machine runs with
 603 MEMORY-SIZE MiB of memory.
 604
 605 MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
 606 systems into the guest.
 607
 608 When FULL-BOOT? is true, the returned script runs everything starting from the
 609 bootloader; otherwise it directly starts the operating system kernel.  The
 610 DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
 611 it is mostly useful when FULL-BOOT?  is true."
 612   (mlet* %store-monad ((os ->  (virtualized-operating-system os mappings full-boot?))
 613                        (os-drv (operating-system-derivation os))
 614                        (image  (system-qemu-image/shared-store
 615                                 os
 616                                 #:full-boot? full-boot?
 617                                 #:disk-image-size disk-image-size)))
 618     (define kernel-arguments
 619       #~(list #$@(if graphic? #~() #~("console=ttyS0"))
 620               #+@(operating-system-kernel-arguments os os-drv "/dev/vda1")))
 621
 622     (define qemu-exec
 623       #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
 624               #$@(if full-boot?
 625                      #~()
 626                      #~("-kernel" #$(operating-system-kernel-file os)
 627                         "-initrd" #$(file-append os-drv "/initrd")
 628                         (format #f "-append ~s"
 629                                 (string-join #$kernel-arguments " "))))
 630               #$@(common-qemu-options image
 631                                       (map file-system-mapping-source
 632                                            (cons %store-mapping mappings)))
 633               "-m " (number->string #$memory-size)
 634               #$@options))
 635
 636     (define builder
 637       #~(call-with-output-file #$output
 638           (lambda (port)
 639             (format port "#!~a~% exec ~a \"$@\"~%"
 640                     #$(file-append bash "/bin/sh")
 641                     (string-join #$qemu-exec " "))
 642             (chmod port #o555))))
 643
 644     (gexp->derivation "run-vm.sh" builder)))
 645
 646 \f
 647 ;;;
 648 ;;; High-level abstraction.
 649 ;;;
 650
 651 (define-record-type* <virtual-machine> %virtual-machine
 652   make-virtual-machine
 653   virtual-machine?
 654   (operating-system virtual-machine-operating-system) ;<operating-system>
 655   (qemu             virtual-machine-qemu              ;<package>
 656                     (default qemu))
 657   (graphic?         virtual-machine-graphic?      ;Boolean
 658                     (default #f))
 659   (memory-size      virtual-machine-memory-size   ;integer (MiB)
 660                     (default 256))
 661   (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
 662                     (default '())))
 663
 664 (define-syntax virtual-machine
 665   (syntax-rules ()
 666     "Declare a virtual machine running the specified OS, with the given
 667 options."
 668     ((_ os)                                       ;shortcut
 669      (%virtual-machine (operating-system os)))
 670     ((_ fields ...)
 671      (%virtual-machine fields ...))))
 672
 673 (define (port-forwardings->qemu-options forwardings)
 674   "Return the QEMU option for the given port FORWARDINGS as a string, where
 675 FORWARDINGS is a list of host-port/guest-port pairs."
 676   (string-join
 677    (map (match-lambda
 678           ((host-port . guest-port)
 679            (string-append "hostfwd=tcp::"
 680                           (number->string host-port)
 681                           "-:" (number->string guest-port))))
 682         forwardings)
 683    ","))
 684
 685 (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
 686                                                 system target)
 687   ;; XXX: SYSTEM and TARGET are ignored.
 688   (match vm
 689     (($ <virtual-machine> os qemu graphic? memory-size ())
 690      (system-qemu-image/shared-store-script os
 691                                             #:qemu qemu
 692                                             #:graphic? graphic?
 693                                             #:memory-size memory-size))
 694     (($ <virtual-machine> os qemu graphic? memory-size forwardings)
 695      (let ((options
 696             `("-net" ,(string-append
 697                        "user,"
 698                        (port-forwardings->qemu-options forwardings)))))
 699        (system-qemu-image/shared-store-script os
 700                                               #:qemu qemu
 701                                               #:graphic? graphic?
 702                                               #:memory-size memory-size
 703                                               #:options options)))))
 704
 705 ;;; vm.scm ends here