gnu/system/vm.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
   4 ;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu system vm)
  22   #:use-module (guix config)
  23   #:use-module (guix store)
  24   #:use-module (guix gexp)
  25   #:use-module (guix derivations)
  26   #:use-module (guix packages)
  27   #:use-module (guix monads)
  28   #:use-module (guix records)
  29   #:use-module (guix modules)
  30
  31   #:use-module ((gnu build vm)
  32                 #:select (qemu-command))
  33   #:use-module (gnu packages base)
  34   #:use-module (gnu packages guile)
  35   #:use-module (gnu packages gawk)
  36   #:use-module (gnu packages bash)
  37   #:use-module (gnu packages less)
  38   #:use-module (gnu packages qemu)
  39   #:use-module (gnu packages disk)
  40   #:use-module (gnu packages zile)
  41   #:use-module (gnu packages grub)
  42   #:use-module (gnu packages linux)
  43   #:use-module (gnu packages package-management)
  44   #:use-module ((gnu packages make-bootstrap)
  45                 #:select (%guile-static-stripped))
  46   #:use-module (gnu packages admin)
  47
  48   #:use-module (gnu system shadow)
  49   #:use-module (gnu system pam)
  50   #:use-module (gnu system linux-initrd)
  51   #:use-module (gnu system grub)
  52   #:use-module (gnu system file-systems)
  53   #:use-module (gnu system)
  54   #:use-module (gnu services)
  55
  56   #:use-module (srfi srfi-1)
  57   #:use-module (srfi srfi-26)
  58   #:use-module (ice-9 match)
  59
  60   #:export (expression->derivation-in-linux-vm
  61             qemu-image
  62             virtualized-operating-system
  63             system-qemu-image
  64
  65             system-qemu-image/shared-store
  66             system-qemu-image/shared-store-script
  67             system-disk-image))
  68
  69 \f
  70 ;;; Commentary:
  71 ;;;
  72 ;;; Tools to evaluate build expressions within virtual machines.
  73 ;;;
  74 ;;; Code:
  75
  76 (define %linux-vm-file-systems
  77   ;; File systems mounted for 'derivation-in-linux-vm'.  The store and /xchg
  78   ;; directory are shared with the host over 9p.
  79   (list (file-system
  80           (mount-point (%store-prefix))
  81           (device "store")
  82           (type "9p")
  83           (needed-for-boot? #t)
  84           (options "trans=virtio")
  85           (check? #f))
  86         (file-system
  87           (mount-point "/xchg")
  88           (device "xchg")
  89           (type "9p")
  90           (needed-for-boot? #t)
  91           (options "trans=virtio")
  92           (check? #f))))
  93
  94 (define* (expression->derivation-in-linux-vm name exp
  95                                              #:key
  96                                              (system (%current-system))
  97                                              (linux linux-libre)
  98                                              initrd
  99                                              (qemu qemu-minimal)
 100                                              (env-vars '())
 101                                              (guile-for-build
 102                                               (%guile-for-build))
 103
 104                                              (make-disk-image? #f)
 105                                              (references-graphs #f)
 106                                              (memory-size 256)
 107                                              (disk-image-format "qcow2")
 108                                              (disk-image-size
 109                                               (* 100 (expt 2 20))))
 110   "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
 111 derivation).  In the virtual machine, EXP has access to all its inputs from the
 112 store; it should put its output files in the `/xchg' directory, which is
 113 copied to the derivation's output when the VM terminates.  The virtual machine
 114 runs with MEMORY-SIZE MiB of memory.
 115
 116 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
 117 DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
 118 return it.
 119
 120 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 121 pairs, as for `derivation'.  The files containing the reference graphs are
 122 made available under the /xchg CIFS share."
 123   (mlet* %store-monad
 124       ((user-builder (gexp->file "builder-in-linux-vm" exp))
 125        (loader       (gexp->file "linux-vm-loader"
 126                                  #~(primitive-load #$user-builder)))
 127        (coreutils -> (canonical-package coreutils))
 128        (initrd       (if initrd                   ; use the default initrd?
 129                          (return initrd)
 130                          (base-initrd %linux-vm-file-systems
 131                                       #:linux linux
 132                                       #:virtio? #t
 133                                       #:qemu-networking? #t))))
 134
 135     (define builder
 136       ;; Code that launches the VM that evaluates EXP.
 137       (with-imported-modules (source-module-closure '((guix build utils)
 138                                                       (gnu build vm)))
 139         #~(begin
 140             (use-modules (guix build utils)
 141                          (gnu build vm))
 142
 143             (let ((inputs  '#$(list qemu coreutils))
 144                   (linux   (string-append #$linux "/bzImage"))
 145                   (initrd  (string-append #$initrd "/initrd"))
 146                   (loader  #$loader)
 147                   (graphs  '#$(match references-graphs
 148                                 (((graph-files . _) ...) graph-files)
 149                                 (_ #f))))
 150
 151               (set-path-environment-variable "PATH" '("bin") inputs)
 152
 153               (load-in-linux-vm loader
 154                                 #:output #$output
 155                                 #:linux linux #:initrd initrd
 156                                 #:memory-size #$memory-size
 157                                 #:make-disk-image? #$make-disk-image?
 158                                 #:disk-image-format #$disk-image-format
 159                                 #:disk-image-size #$disk-image-size
 160                                 #:references-graphs graphs)))))
 161
 162     (gexp->derivation name builder
 163                       ;; TODO: Require the "kvm" feature.
 164                       #:system system
 165                       #:env-vars env-vars
 166                       #:guile-for-build guile-for-build
 167                       #:references-graphs references-graphs)))
 168
 169 (define* (qemu-image #:key
 170                      (name "qemu-image")
 171                      (system (%current-system))
 172                      (qemu qemu-minimal)
 173                      (disk-image-size (* 100 (expt 2 20)))
 174                      (disk-image-format "qcow2")
 175                      (file-system-type "ext4")
 176                      file-system-label
 177                      os-derivation
 178                      grub-configuration
 179                      (register-closures? #t)
 180                      (inputs '())
 181                      copy-inputs?)
 182   "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
 183 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
 184 Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
 185 partition.  The returned image is a full disk image that runs OS-DERIVATION,
 186 with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
 187 file (GRUB-CONFIGURATION must be the name of a file in the VM.)
 188
 189 INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 190 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
 191 register INPUTS in the store database of the image so that Guix can be used in
 192 the image."
 193   (expression->derivation-in-linux-vm
 194    name
 195    (with-imported-modules (source-module-closure '((gnu build vm)
 196                                                    (guix build utils)))
 197      #~(begin
 198          (use-modules (gnu build vm)
 199                       (guix build utils))
 200
 201          (let ((inputs
 202                 '#$(append (list qemu parted grub e2fsprogs)
 203                            (map canonical-package
 204                                 (list sed grep coreutils findutils gawk))
 205                            (if register-closures? (list guix) '())))
 206
 207                ;; This variable is unused but allows us to add INPUTS-TO-COPY
 208                ;; as inputs.
 209                (to-register
 210                 '#$(map (match-lambda
 211                           ((name thing) thing)
 212                           ((name thing output) `(,thing ,output)))
 213                         inputs)))
 214
 215            (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 216
 217            (let* ((graphs     '#$(match inputs
 218                                    (((names . _) ...)
 219                                     names)))
 220                   (initialize (root-partition-initializer
 221                                #:closures graphs
 222                                #:copy-closures? #$copy-inputs?
 223                                #:register-closures? #$register-closures?
 224                                #:system-directory #$os-derivation))
 225                   (partitions (list (partition
 226                                      (size #$(- disk-image-size
 227                                                 (* 10 (expt 2 20))))
 228                                      (label #$file-system-label)
 229                                      (file-system #$file-system-type)
 230                                      (bootable? #t)
 231                                      (initializer initialize)))))
 232              (initialize-hard-disk "/dev/vda"
 233                                    #:partitions partitions
 234                                    #:grub.cfg #$grub-configuration)
 235              (reboot)))))
 236    #:system system
 237    #:make-disk-image? #t
 238    #:disk-image-size disk-image-size
 239    #:disk-image-format disk-image-format
 240    #:references-graphs inputs))
 241
 242 \f
 243 ;;;
 244 ;;; VM and disk images.
 245 ;;;
 246
 247 (define* (system-disk-image os
 248                             #:key
 249                             (name "disk-image")
 250                             (file-system-type "ext4")
 251                             (disk-image-size (* 900 (expt 2 20)))
 252                             (volatile? #t))
 253   "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
 254 system described by OS.  Said image can be copied on a USB stick as is.  When
 255 VOLATILE? is true, the root file system is made volatile; this is useful
 256 to USB sticks meant to be read-only."
 257   (define root-label
 258     ;; Volume name of the root file system.  Since we don't know which device
 259     ;; will hold it, we use the volume name to find it (using the UUID would
 260     ;; be even better, but somewhat less convenient.)
 261     "gnu-disk-image")
 262
 263   (define file-systems-to-keep
 264     (remove (lambda (fs)
 265               (string=? (file-system-mount-point fs) "/"))
 266             (operating-system-file-systems os)))
 267
 268   (let ((os (operating-system (inherit os)
 269               ;; Since this is meant to be used on real hardware, don't
 270               ;; install QEMU networking or anything like that.  Assume USB
 271               ;; mass storage devices (usb-storage.ko) are available.
 272               (initrd (lambda (file-systems . rest)
 273                         (apply base-initrd file-systems
 274                                #:volatile-root? #t
 275                                rest)))
 276
 277               ;; Force our own root file system.
 278               (file-systems (cons (file-system
 279                                     (mount-point "/")
 280                                     (device root-label)
 281                                     (title 'label)
 282                                     (type file-system-type))
 283                                   file-systems-to-keep)))))
 284
 285     (mlet* %store-monad ((os-drv   (operating-system-derivation os))
 286                          (grub.cfg (operating-system-grub.cfg os)))
 287       (qemu-image #:name name
 288                   #:os-derivation os-drv
 289                   #:grub-configuration grub.cfg
 290                   #:disk-image-size disk-image-size
 291                   #:disk-image-format "raw"
 292                   #:file-system-type file-system-type
 293                   #:file-system-label root-label
 294                   #:copy-inputs? #t
 295                   #:register-closures? #t
 296                   #:inputs `(("system" ,os-drv)
 297                              ("grub.cfg" ,grub.cfg))))))
 298
 299 (define* (system-qemu-image os
 300                             #:key
 301                             (file-system-type "ext4")
 302                             (disk-image-size (* 900 (expt 2 20))))
 303   "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
 304 of the GNU system as described by OS."
 305   (define file-systems-to-keep
 306     ;; Keep only file systems other than root and not normally bound to real
 307     ;; devices.
 308     (remove (lambda (fs)
 309               (let ((target (file-system-mount-point fs))
 310                     (source (file-system-device fs)))
 311                 (or (string=? target "/")
 312                     (string-prefix? "/dev/" source))))
 313             (operating-system-file-systems os)))
 314
 315   (let ((os (operating-system (inherit os)
 316               ;; Use an initrd with the whole QEMU shebang.
 317               (initrd (lambda (file-systems . rest)
 318                         (apply base-initrd file-systems
 319                                #:virtio? #t
 320                                #:qemu-networking? #t
 321                                rest)))
 322
 323               ;; Force our own root file system.
 324               (file-systems (cons (file-system
 325                                     (mount-point "/")
 326                                     (device "/dev/sda1")
 327                                     (type file-system-type))
 328                                   file-systems-to-keep)))))
 329     (mlet* %store-monad
 330         ((os-drv      (operating-system-derivation os))
 331          (grub.cfg    (operating-system-grub.cfg os)))
 332       (qemu-image  #:os-derivation os-drv
 333                    #:grub-configuration grub.cfg
 334                    #:disk-image-size disk-image-size
 335                    #:file-system-type file-system-type
 336                    #:inputs `(("system" ,os-drv)
 337                               ("grub.cfg" ,grub.cfg))
 338                    #:copy-inputs? #t))))
 339
 340 \f
 341 ;;;
 342 ;;; VMs that share file systems with the host.
 343 ;;;
 344
 345 (define (file-system->mount-tag fs)
 346   "Return a 9p mount tag for host file system FS."
 347   ;; QEMU mount tags cannot contain slashes and cannot start with '_'.
 348   ;; Compute an identifier that corresponds to the rules.
 349   (string-append "TAG"
 350                  (string-map (match-lambda
 351                               (#\/ #\_)
 352                               (chr chr))
 353                              fs)))
 354
 355 (define (mapping->file-system mapping)
 356   "Return a 9p file system that realizes MAPPING."
 357   (match mapping
 358     (($ <file-system-mapping> source target writable?)
 359      (file-system
 360        (mount-point target)
 361        (device (file-system->mount-tag source))
 362        (type "9p")
 363        (flags (if writable? '() '(read-only)))
 364        (options (string-append "trans=virtio"))
 365        (check? #f)
 366        (create-mount-point? #t)))))
 367
 368 (define (virtualized-operating-system os mappings)
 369   "Return an operating system based on OS suitable for use in a virtualized
 370 environment with the store shared with the host.  MAPPINGS is a list of
 371 <file-system-mapping> to realize in the virtualized OS."
 372   (define user-file-systems
 373     ;; Remove file systems that conflict with those added below, or that are
 374     ;; normally bound to real devices.
 375     (remove (lambda (fs)
 376               (let ((target (file-system-mount-point fs))
 377                     (source (file-system-device fs)))
 378                 (or (string=? target (%store-prefix))
 379                     (string=? target "/")
 380                     (and (eq? 'device (file-system-title fs))
 381                          (string-prefix? "/dev/" source)))))
 382             (operating-system-file-systems os)))
 383
 384   (operating-system (inherit os)
 385     (initrd (lambda (file-systems . rest)
 386               (apply base-initrd file-systems
 387                      #:volatile-root? #t
 388                      #:virtio? #t
 389                      #:qemu-networking? #t
 390                      rest)))
 391
 392     ;; Disable swap.
 393     (swap-devices '())
 394
 395     (file-systems (cons* (file-system
 396                            (mount-point "/")
 397                            (device "/dev/vda1")
 398                            (type "ext4"))
 399
 400                          (file-system (inherit
 401                                        (mapping->file-system %store-mapping))
 402                             (needed-for-boot? #t))
 403
 404                          (append (map mapping->file-system mappings)
 405                                  user-file-systems)))))
 406
 407 (define* (system-qemu-image/shared-store
 408           os
 409           #:key
 410           full-boot?
 411           (disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
 412   "Return a derivation that builds a QEMU image of OS that shares its store
 413 with the host.
 414
 415 When FULL-BOOT? is true, return an image that does a complete boot sequence,
 416 bootloaded included; thus, make a disk image that contains everything the
 417 bootloader refers to: OS kernel, initrd, bootloader data, etc."
 418   (mlet* %store-monad ((os-drv   (operating-system-derivation os))
 419                        (grub.cfg (operating-system-grub.cfg os)))
 420     ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
 421     ;; GRUB.CFG and all its dependencies, including the output of OS-DRV.
 422     ;; This is more than needed (we only need the kernel, initrd, GRUB for its
 423     ;; font, and the background image), but it's hard to filter that.
 424     (qemu-image #:os-derivation os-drv
 425                 #:grub-configuration grub.cfg
 426                 #:disk-image-size disk-image-size
 427                 #:inputs (if full-boot?
 428                              `(("grub.cfg" ,grub.cfg))
 429                              '())
 430
 431                 ;; XXX: Passing #t here is too slow, so let it off by default.
 432                 #:register-closures? #f
 433                 #:copy-inputs? full-boot?)))
 434
 435 (define* (common-qemu-options image shared-fs)
 436   "Return the a string-value gexp with the common QEMU options to boot IMAGE,
 437 with '-virtfs' options for the host file systems listed in SHARED-FS."
 438   (define (virtfs-option fs)
 439     #~(string-append "-virtfs local,path=\"" #$fs
 440                      "\",security_model=none,mount_tag=\""
 441                      #$(file-system->mount-tag fs)
 442                      "\" "))
 443
 444   #~(string-append
 445      ;; Only enable kvm if we see /dev/kvm exists.
 446      ;; This allows users without hardware virtualization to still use these
 447      ;; commands.
 448      #$(if (file-exists? "/dev/kvm")
 449            " -enable-kvm "
 450            "")
 451      " -no-reboot -net nic,model=virtio \
 452   " #$@(map virtfs-option shared-fs) " \
 453   -net user \
 454   -vga std \
 455   -drive file=" #$image
 456   ",if=virtio,cache=writeback,werror=report,readonly \
 457   -m 256"))
 458
 459 (define* (system-qemu-image/shared-store-script os
 460                                                 #:key
 461                                                 (qemu qemu)
 462                                                 (graphic? #t)
 463                                                 (mappings '())
 464                                                 full-boot?
 465                                                 (disk-image-size
 466                                                  (* (if full-boot? 500 30)
 467                                                     (expt 2 20))))
 468   "Return a derivation that builds a script to run a virtual machine image of
 469 OS that shares its store with the host.
 470
 471 MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
 472 systems into the guest.
 473
 474 When FULL-BOOT? is true, the returned script runs everything starting from the
 475 bootloader; otherwise it directly starts the operating system kernel.  The
 476 DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
 477 it is mostly useful when FULL-BOOT?  is true."
 478   (mlet* %store-monad ((os ->  (virtualized-operating-system os mappings))
 479                        (os-drv (operating-system-derivation os))
 480                        (image  (system-qemu-image/shared-store
 481                                 os
 482                                 #:full-boot? full-boot?
 483                                 #:disk-image-size disk-image-size)))
 484     (define builder
 485       #~(call-with-output-file #$output
 486           (lambda (port)
 487             (display
 488              (string-append "#!" #$bash "/bin/sh
 489 exec " #$qemu "/bin/" #$(qemu-command (%current-system))
 490
 491 #$@(if full-boot?
 492        #~()
 493        #~(" -kernel " #$(operating-system-kernel os) "/bzImage \
 494             -initrd " #$os-drv "/initrd \
 495             -append \"" #$(if graphic? "" "console=ttyS0 ")
 496             "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1 "
 497             (string-join (list #+@(operating-system-kernel-arguments os))) "\" "))
 498 #$(common-qemu-options image
 499                        (map file-system-mapping-source
 500                             (cons %store-mapping mappings)))
 501 " \"$@\"\n")
 502              port)
 503             (chmod port #o555))))
 504
 505     (gexp->derivation "run-vm.sh" builder)))
 506
 507 ;;; vm.scm ends here