gnu/system/vm.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Christine Lemmer-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 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
   8 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (gnu system vm)
  25   #:use-module (guix config)
  26   #:use-module (guix store)
  27   #:use-module (guix gexp)
  28   #:use-module (guix derivations)
  29   #:use-module (guix packages)
  30   #:use-module (guix monads)
  31   #:use-module (guix records)
  32   #:use-module (guix modules)
  33   #:use-module (guix utils)
  34   #:use-module (gcrypt hash)
  35   #:use-module (guix base32)
  36   #:use-module ((guix self) #:select (make-config.scm))
  37
  38   #:use-module ((gnu build marionette)
  39                 #:select (qemu-command))
  40   #:use-module (gnu packages base)
  41   #:use-module (gnu packages bootloaders)
  42   #:use-module (gnu packages cdrom)
  43   #:use-module (gnu packages compression)
  44   #:use-module (gnu packages guile)
  45   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  46   #:use-module (gnu packages gawk)
  47   #:use-module (gnu packages bash)
  48   #:use-module (gnu packages virtualization)
  49   #:use-module (gnu packages disk)
  50   #:use-module (gnu packages linux)
  51
  52   #:use-module (gnu bootloader)
  53   #:use-module (gnu bootloader grub)
  54   #:use-module (gnu image)
  55   #:use-module (gnu system image)
  56   #:use-module (gnu system linux-container)
  57   #:use-module (gnu system linux-initrd)
  58   #:use-module (gnu bootloader)
  59   #:use-module (gnu system file-systems)
  60   #:use-module (gnu system)
  61   #:use-module (gnu services)
  62   #:use-module (gnu services base)
  63   #:use-module (gnu system uuid)
  64
  65   #:use-module ((srfi srfi-1) #:hide (partition))
  66   #:use-module (srfi srfi-26)
  67   #:use-module (rnrs bytevectors)
  68   #:use-module (ice-9 match)
  69
  70   #:export (virtualized-operating-system
  71             system-qemu-image/shared-store-script
  72
  73             virtual-machine
  74             virtual-machine?))
  75
  76 \f
  77 ;;; Commentary:
  78 ;;;
  79 ;;; Tools to evaluate build expressions within virtual machines.
  80 ;;;
  81 ;;; Code:
  82
  83 ;; By default, the msize value is 8 KiB, which according to QEMU is
  84 ;; insufficient and would degrade performance.  The msize value should roughly
  85 ;; match the bandwidth of the system's IO (see:
  86 ;; https://wiki.qemu.org/Documentation/9psetup#msize).  Use 100 MiB as a
  87 ;; conservative default.
  88 (define %default-msize-value (* 100 (expt 2 20))) ;100 MiB
  89
  90 (define %linux-vm-file-systems
  91   ;; File systems mounted for 'derivation-in-linux-vm'.  These are shared with
  92   ;; the host over 9p.
  93   ;;
  94   ;; The 9p documentation says that cache=loose is "intended for exclusive,
  95   ;; read-only mounts", without additional details.  It's much faster than the
  96   ;; default cache=none, especially when copying and registering store items.
  97   ;; Thus, use cache=loose, except for /xchg where we want to ensure
  98   ;; consistency.
  99   (list (file-system
 100           (mount-point (%store-prefix))
 101           (device "store")
 102           (type "9p")
 103           (needed-for-boot? #t)
 104           (flags '(read-only))
 105           (options (format #f "trans=virtio,cache=loose,msize=~a"
 106                            %default-msize-value))
 107           (check? #f))
 108         (file-system
 109           (mount-point "/xchg")
 110           (device "xchg")
 111           (type "9p")
 112           (needed-for-boot? #t)
 113           (options (format #f "trans=virtio,msize=~a" %default-msize-value))
 114           (check? #f))
 115         (file-system
 116           (mount-point "/tmp")
 117           (device "tmp")
 118           (type "9p")
 119           (needed-for-boot? #t)
 120           (options (format #f "trans=virtio,cache=loose,msize=~a"
 121                            %default-msize-value))
 122           (check? #f))))
 123
 124 \f
 125 ;;;
 126 ;;; VMs that share file systems with the host.
 127 ;;;
 128
 129 (define (file-system->mount-tag fs)
 130   "Return a 9p mount tag for host file system FS."
 131   ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain
 132   ;; slashes, and cannot start with '_'.  Compute an identifier that
 133   ;; corresponds to the rules.
 134   (string-append "TAG"
 135                  (string-drop (bytevector->base32-string
 136                                (sha1 (string->utf8 fs)))
 137                               4)))
 138
 139 (define (mapping->file-system mapping)
 140   "Return a 9p file system that realizes MAPPING."
 141   (match mapping
 142     (($ <file-system-mapping> source target writable?)
 143      (file-system
 144        (mount-point target)
 145        (device (file-system->mount-tag source))
 146        (type "9p")
 147        (flags (if writable? '() '(read-only)))
 148        (options (string-append "trans=virtio"
 149                                (if writable? "" ",cache=loose")
 150                                ",msize=" (number->string %default-msize-value)))
 151        (check? #f)
 152        (create-mount-point? #t)))))
 153
 154 (define* (virtualized-operating-system os mappings
 155                                        #:key (full-boot? #f) volatile?)
 156   "Return an operating system based on OS suitable for use in a virtualized
 157 environment with the store shared with the host.  MAPPINGS is a list of
 158 <file-system-mapping> to realize in the virtualized OS."
 159   (define user-file-systems
 160     ;; Remove file systems that conflict with those added below, or that are
 161     ;; normally bound to real devices.
 162     (remove (lambda (fs)
 163               (let ((target (file-system-mount-point fs))
 164                     (source (file-system-device fs)))
 165                 (or (string=? target (%store-prefix))
 166                     (string=? target "/")
 167                     (and (string? source)
 168                          (string-prefix? "/dev/" source))
 169
 170                     ;; Labels and UUIDs are necessarily invalid in the VM.
 171                     (and (file-system-mount? fs)
 172                          (or (file-system-label? source)
 173                              (uuid? source))))))
 174             (operating-system-file-systems os)))
 175
 176   (define virtual-file-systems
 177     (cons (file-system
 178             (mount-point "/")
 179             (device "/dev/vda1")
 180             (type "ext4"))
 181
 182           (append (map mapping->file-system mappings)
 183                   user-file-systems)))
 184
 185   (operating-system (inherit os)
 186
 187     ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware),
 188     ;; force the traditional i386/BIOS method.
 189     ;; See <https://bugs.gnu.org/28768>.
 190     (bootloader (bootloader-configuration
 191                   (inherit (operating-system-bootloader os))
 192                   (bootloader grub-bootloader)
 193                   (targets '("/dev/vda"))))
 194
 195     (initrd (lambda (file-systems . rest)
 196               (apply (operating-system-initrd os)
 197                      file-systems
 198                      #:volatile-root? volatile?
 199                      rest)))
 200
 201     ;; Disable swap.
 202     (swap-devices '())
 203
 204     ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
 205     ;; since that would lead the bootloader config to look for the kernel and
 206     ;; initrd in it.
 207     (file-systems (if full-boot?
 208                       virtual-file-systems
 209                       (cons
 210                        (file-system
 211                          (inherit (mapping->file-system %store-mapping))
 212                          (needed-for-boot? #t))
 213                        virtual-file-systems)))))
 214
 215 (define* (common-qemu-options image shared-fs
 216                               #:key rw-image?)
 217   "Return the a string-value gexp with the common QEMU options to boot IMAGE,
 218 with '-virtfs' options for the host file systems listed in SHARED-FS."
 219
 220   (define (virtfs-option fs)
 221     #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
 222               #$fs #$(file-system->mount-tag fs)))
 223
 224   #~(;; Only enable kvm if we see /dev/kvm exists.
 225      ;; This allows users without hardware virtualization to still use these
 226      ;; commands.
 227      #$@(if (file-exists? "/dev/kvm")
 228             '("-enable-kvm")
 229             '())
 230
 231      "-no-reboot"
 232      "-object" "rng-random,filename=/dev/urandom,id=guix-vm-rng"
 233      "-device" "virtio-rng-pci,rng=guix-vm-rng"
 234
 235      #$@(map virtfs-option shared-fs)
 236      #$@(if rw-image?
 237             #~((format #f "-drive file=~a,if=virtio" #$image))
 238             #~((format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly=on"
 239                        #$image)))))
 240
 241 (define* (system-qemu-image/shared-store-script os
 242                                                 #:key
 243                                                 (system (%current-system))
 244                                                 (target (%current-target-system))
 245                                                 (qemu qemu)
 246                                                 (graphic? #t)
 247                                                 (volatile? #t)
 248                                                 (memory-size 512)
 249                                                 (mappings '())
 250                                                 full-boot?
 251                                                 (disk-image-size
 252                                                  (* (if full-boot? 500 70)
 253                                                     (expt 2 20)))
 254                                                 (options '()))
 255   "Return a derivation that builds a script to run a virtual machine image of
 256 OS that shares its store with the host.  The virtual machine runs with
 257 MEMORY-SIZE MiB of memory.
 258
 259 MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
 260 systems into the guest.
 261
 262 When FULL-BOOT? is true, the returned script runs everything starting from the
 263 bootloader; otherwise it directly starts the operating system kernel.  When
 264 VOLATILE? is true, an overlay is created on top of a read-only
 265 storage. Otherwise the storage is made persistent.  The DISK-IMAGE-SIZE
 266 parameter specifies the size in bytes of the root disk image; it is mostly
 267 useful when FULL-BOOT?  is true."
 268   (mlet* %store-monad ((os ->  (virtualized-operating-system
 269                                 os mappings
 270                                 #:full-boot? full-boot?
 271                                 #:volatile? volatile?))
 272                        (base-image -> (system-image
 273                                        (image
 274                                         (inherit
 275                                          (raw-with-offset-disk-image))
 276                                         (operating-system os)
 277                                         (size disk-image-size)
 278                                         (shared-store?
 279                                          (and (not full-boot?) volatile?))
 280                                         (volatile-root? volatile?)))))
 281     (define kernel-arguments
 282       #~(list #$@(if graphic? #~() #~("console=ttyS0"))
 283               #+@(operating-system-kernel-arguments os "/dev/vda1")))
 284
 285     (define rw-image
 286       #~(format #f "/tmp/guix-image-~a" (basename #$base-image)))
 287
 288     (define qemu-exec
 289       #~(list #+(file-append qemu "/bin/"
 290                              (qemu-command (or target system)))
 291               ;; Tells qemu to use the terminal it was started in for IO.
 292               #$@(if graphic? '() #~("-nographic"))
 293               #$@(if full-boot?
 294                      #~()
 295                      #~("-kernel" #$(operating-system-kernel-file os)
 296                         "-initrd" #$(file-append os "/initrd")
 297                         (format #f "-append ~s"
 298                                 (string-join #$kernel-arguments " "))))
 299               #$@(common-qemu-options (if volatile? base-image rw-image)
 300                                       (map file-system-mapping-source
 301                                            (cons %store-mapping mappings))
 302                                       #:rw-image? (not volatile?))
 303               "-m " (number->string #$memory-size)
 304               #$@options))
 305
 306     (define builder
 307       #~(call-with-output-file #$output
 308           (lambda (port)
 309             (format port "#!~a~%"
 310                     #+(file-append bash "/bin/sh"))
 311             (when (not #$volatile?)
 312               (format port "~a~%"
 313                       #$(program-file "copy-image"
 314                                       #~(unless (file-exists? #$rw-image)
 315                                           (copy-file #$base-image #$rw-image)
 316                                           (chmod #$rw-image #o640)))))
 317             (format port "exec ~a \"$@\"~%"
 318                     (string-join #$qemu-exec " "))
 319             (chmod port #o555))))
 320
 321     (gexp->derivation "run-vm.sh" builder)))
 322
 323 \f
 324 ;;;
 325 ;;; High-level abstraction.
 326 ;;;
 327
 328 (define-record-type* <virtual-machine> %virtual-machine
 329   make-virtual-machine
 330   virtual-machine?
 331   (operating-system virtual-machine-operating-system) ;<operating-system>
 332   (qemu             virtual-machine-qemu              ;<package>
 333                     (default qemu-minimal))
 334   (volatile?        virtual-machine-volatile?    ;Boolean
 335                     (default #t))
 336   (graphic?         virtual-machine-graphic?      ;Boolean
 337                     (default #f))
 338   (memory-size      virtual-machine-memory-size   ;integer (MiB)
 339                     (default 256))
 340   (disk-image-size  virtual-machine-disk-image-size   ;integer (bytes)
 341                     (default 'guess))
 342   (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
 343                     (default '())))
 344
 345 (define-syntax virtual-machine
 346   (syntax-rules ()
 347     "Declare a virtual machine running the specified OS, with the given
 348 options."
 349     ((_ os)                                       ;shortcut
 350      (%virtual-machine (operating-system os)))
 351     ((_ fields ...)
 352      (%virtual-machine fields ...))))
 353
 354 (define (port-forwardings->qemu-options forwardings)
 355   "Return the QEMU option for the given port FORWARDINGS as a string, where
 356 FORWARDINGS is a list of host-port/guest-port pairs."
 357   (string-join
 358    (map (match-lambda
 359           ((host-port . guest-port)
 360            (string-append "hostfwd=tcp::"
 361                           (number->string host-port)
 362                           "-:" (number->string guest-port))))
 363         forwardings)
 364    ","))
 365
 366 (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
 367                                                 system target)
 368   (match vm
 369     (($ <virtual-machine> os qemu volatile? graphic? memory-size
 370                           disk-image-size ())
 371      (system-qemu-image/shared-store-script os
 372                                             #:system system
 373                                             #:target target
 374                                             #:qemu qemu
 375                                             #:graphic? graphic?
 376                                             #:volatile? volatile?
 377                                             #:memory-size memory-size
 378                                             #:disk-image-size
 379                                             disk-image-size))
 380     (($ <virtual-machine> os qemu volatile? graphic? memory-size
 381                           disk-image-size forwardings)
 382      (let ((options
 383             `("-nic" ,(string-append
 384                        "user,model=virtio-net-pci,"
 385                        (port-forwardings->qemu-options forwardings)))))
 386        (system-qemu-image/shared-store-script os
 387                                               #:system system
 388                                               #:target target
 389                                               #:qemu qemu
 390                                               #:graphic? graphic?
 391                                               #:volatile? volatile?
 392                                               #:memory-size memory-size
 393                                               #:disk-image-size
 394                                               disk-image-size
 395                                               #:options options)))))
 396
 397 ;;; vm.scm ends here