gnu/system/vm.scm

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