gnu/system/vm.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu system vm)
  20   #:use-module (guix config)
  21   #:use-module (guix store)
  22   #:use-module (guix gexp)
  23   #:use-module (guix derivations)
  24   #:use-module (guix packages)
  25   #:use-module (guix monads)
  26   #:use-module ((gnu build vm)
  27                 #:select (qemu-command))
  28   #:use-module (gnu packages base)
  29   #:use-module (gnu packages guile)
  30   #:use-module (gnu packages gawk)
  31   #:use-module (gnu packages bash)
  32   #:use-module (gnu packages less)
  33   #:use-module (gnu packages qemu)
  34   #:use-module (gnu packages disk)
  35   #:use-module (gnu packages zile)
  36   #:use-module (gnu packages grub)
  37   #:use-module (gnu packages linux)
  38   #:use-module (gnu packages package-management)
  39   #:use-module ((gnu packages make-bootstrap)
  40                 #:select (%guile-static-stripped))
  41   #:use-module (gnu packages admin)
  42
  43   #:use-module (gnu system shadow)
  44   #:use-module (gnu system linux)
  45   #:use-module (gnu system linux-initrd)
  46   #:use-module (gnu system grub)
  47   #:use-module (gnu system file-systems)
  48   #:use-module (gnu system)
  49   #:use-module (gnu services)
  50
  51   #:use-module (srfi srfi-1)
  52   #:use-module (srfi srfi-26)
  53   #:use-module (ice-9 match)
  54
  55   #:export (expression->derivation-in-linux-vm
  56             qemu-image
  57             system-qemu-image
  58             system-qemu-image/shared-store
  59             system-qemu-image/shared-store-script
  60             system-disk-image))
  61
  62 \f
  63 ;;; Commentary:
  64 ;;;
  65 ;;; Tools to evaluate build expressions within virtual machines.
  66 ;;;
  67 ;;; Code:
  68
  69 (define %linux-vm-file-systems
  70   ;; File systems mounted for 'derivation-in-linux-vm'.  The store and /xchg
  71   ;; directory are shared with the host over 9p.
  72   (list (file-system
  73           (mount-point (%store-prefix))
  74           (device "store")
  75           (type "9p")
  76           (needed-for-boot? #t)
  77           (options "trans=virtio")
  78           (check? #f))
  79         (file-system
  80           (mount-point "/xchg")
  81           (device "xchg")
  82           (type "9p")
  83           (needed-for-boot? #t)
  84           (options "trans=virtio")
  85           (check? #f))))
  86
  87 (define* (expression->derivation-in-linux-vm name exp
  88                                              #:key
  89                                              (system (%current-system))
  90                                              (linux linux-libre)
  91                                              initrd
  92                                              (qemu qemu-headless)
  93                                              (env-vars '())
  94                                              (modules
  95                                               '((gnu build vm)
  96                                                 (gnu build install)
  97                                                 (gnu build linux-boot)
  98                                                 (gnu build file-systems)
  99                                                 (guix build utils)
 100                                                 (guix build store-copy)))
 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 MODULES is the set of modules imported in the execution environment of EXP.
 121
 122 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 123 pairs, as for `derivation'.  The files containing the reference graphs are
 124 made available under the /xchg CIFS share."
 125   (mlet* %store-monad
 126       ((module-dir   (imported-modules modules))
 127        (compiled     (compiled-modules modules))
 128        (user-builder (gexp->file "builder-in-linux-vm" exp))
 129        (loader       (gexp->file "linux-vm-loader"
 130                                  #~(begin
 131                                      (set! %load-path
 132                                            (cons #$module-dir %load-path))
 133                                      (set! %load-compiled-path
 134                                            (cons #$compiled
 135                                                  %load-compiled-path))
 136                                      (primitive-load #$user-builder))))
 137        (coreutils -> (canonical-package coreutils))
 138        (initrd       (if initrd                   ; use the default initrd?
 139                          (return initrd)
 140                          (base-initrd %linux-vm-file-systems
 141                                       #:virtio? #t
 142                                       #:qemu-networking? #t))))
 143
 144     (define builder
 145       ;; Code that launches the VM that evaluates EXP.
 146       #~(begin
 147           (use-modules (guix build utils)
 148                        (gnu build vm))
 149
 150           (let ((inputs  '#$(list qemu coreutils))
 151                 (linux   (string-append #$linux "/bzImage"))
 152                 (initrd  (string-append #$initrd "/initrd"))
 153                 (loader  #$loader)
 154                 (graphs  '#$(match references-graphs
 155                               (((graph-files . _) ...) graph-files)
 156                               (_ #f))))
 157
 158             (set-path-environment-variable "PATH" '("bin") inputs)
 159
 160             (load-in-linux-vm loader
 161                               #:output #$output
 162                               #:linux linux #:initrd initrd
 163                               #:memory-size #$memory-size
 164                               #:make-disk-image? #$make-disk-image?
 165                               #:disk-image-format #$disk-image-format
 166                               #:disk-image-size #$disk-image-size
 167                               #:references-graphs graphs))))
 168
 169     (gexp->derivation name builder
 170                       ;; TODO: Require the "kvm" feature.
 171                       #:system system
 172                       #:env-vars env-vars
 173                       #:modules modules
 174                       #:guile-for-build guile-for-build
 175                       #:references-graphs references-graphs)))
 176
 177 (define* (qemu-image #:key
 178                      (name "qemu-image")
 179                      (system (%current-system))
 180                      (qemu qemu-headless)
 181                      (disk-image-size (* 100 (expt 2 20)))
 182                      (disk-image-format "qcow2")
 183                      (file-system-type "ext4")
 184                      file-system-label
 185                      os-derivation
 186                      grub-configuration
 187                      (register-closures? #t)
 188                      (inputs '())
 189                      copy-inputs?)
 190   "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
 191 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
 192 Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
 193 partition.  The returned image is a full disk image that runs OS-DERIVATION,
 194 with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
 195 file (GRUB-CONFIGURATION must be the name of a file in the VM.)
 196
 197 INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 198 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
 199 register INPUTS in the store database of the image so that Guix can be used in
 200 the image."
 201   (expression->derivation-in-linux-vm
 202    name
 203    #~(begin
 204        (use-modules (gnu build vm)
 205                     (guix build utils))
 206
 207        (let ((inputs
 208               '#$(append (list qemu parted grub e2fsprogs util-linux)
 209                          (map canonical-package
 210                               (list sed grep coreutils findutils gawk))
 211                          (if register-closures? (list guix) '())))
 212
 213              ;; This variable is unused but allows us to add INPUTS-TO-COPY
 214              ;; as inputs.
 215              (to-register
 216               '#$(map (match-lambda
 217                        ((name thing) thing)
 218                        ((name thing output) `(,thing ,output)))
 219                       inputs)))
 220
 221          (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 222
 223          (let ((graphs '#$(match inputs
 224                             (((names . _) ...)
 225                              names))))
 226            (initialize-hard-disk "/dev/vda"
 227                                  #:system-directory #$os-derivation
 228                                  #:grub.cfg #$grub-configuration
 229                                  #:closures graphs
 230                                  #:copy-closures? #$copy-inputs?
 231                                  #:register-closures? #$register-closures?
 232                                  #:disk-image-size #$disk-image-size
 233                                  #:file-system-type #$file-system-type
 234                                  #:file-system-label #$file-system-label)
 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, but make sure
 271               ;; USB mass storage devices are available.
 272               (initrd (lambda (file-systems . rest)
 273                         (apply base-initrd file-systems
 274                                #:volatile-root? #t
 275                                #:extra-modules '("usb-storage.ko")
 276                                rest)))
 277
 278               ;; Force our own root file system.
 279               (file-systems (cons (file-system
 280                                     (mount-point "/")
 281                                     (device root-label)
 282                                     (title 'label)
 283                                     (type file-system-type))
 284                                   file-systems-to-keep)))))
 285
 286     (mlet* %store-monad ((os-drv   (operating-system-derivation os))
 287                          (grub.cfg (operating-system-grub.cfg os)))
 288       (qemu-image #:name name
 289                   #:os-derivation os-drv
 290                   #:grub-configuration grub.cfg
 291                   #:disk-image-size disk-image-size
 292                   #:disk-image-format "raw"
 293                   #:file-system-type file-system-type
 294                   #:file-system-label root-label
 295                   #:copy-inputs? #t
 296                   #:register-closures? #t
 297                   #:inputs `(("system" ,os-drv)
 298                              ("grub.cfg" ,grub.cfg))))))
 299
 300 (define* (system-qemu-image os
 301                             #:key
 302                             (file-system-type "ext4")
 303                             (disk-image-size (* 900 (expt 2 20))))
 304   "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
 305 of the GNU system as described by OS."
 306   (define file-systems-to-keep
 307     ;; Keep only file systems other than root and not normally bound to real
 308     ;; devices.
 309     (remove (lambda (fs)
 310               (let ((target (file-system-mount-point fs))
 311                     (source (file-system-device fs)))
 312                 (or (string=? target "/")
 313                     (string-prefix? "/dev/" source))))
 314             (operating-system-file-systems os)))
 315
 316   (let ((os (operating-system (inherit os)
 317               ;; Use an initrd with the whole QEMU shebang.
 318               (initrd (lambda (file-systems . rest)
 319                         (apply base-initrd file-systems
 320                                #:virtio? #t
 321                                #:qemu-networking? #t
 322                                rest)))
 323
 324               ;; Force our own root file system.
 325               (file-systems (cons (file-system
 326                                     (mount-point "/")
 327                                     (device "/dev/sda1")
 328                                     (type file-system-type))
 329                                   file-systems-to-keep)))))
 330     (mlet* %store-monad
 331         ((os-drv      (operating-system-derivation os))
 332          (grub.cfg    (operating-system-grub.cfg os)))
 333       (qemu-image  #:os-derivation os-drv
 334                    #:grub-configuration grub.cfg
 335                    #:disk-image-size disk-image-size
 336                    #:file-system-type file-system-type
 337                    #:inputs `(("system" ,os-drv)
 338                               ("grub.cfg" ,grub.cfg))
 339                    #:copy-inputs? #t))))
 340
 341 (define (virtualized-operating-system os)
 342   "Return an operating system based on OS suitable for use in a virtualized
 343 environment with the store shared with the host."
 344   (operating-system (inherit os)
 345     (initrd (lambda (file-systems . rest)
 346               (apply base-initrd file-systems
 347                      #:volatile-root? #t
 348                      #:virtio? #t
 349                      #:qemu-networking? #t
 350                      rest)))
 351
 352     ;; Disable swap.
 353     (swap-devices '())
 354
 355     (file-systems (cons* (file-system
 356                            (mount-point "/")
 357                            (device "/dev/vda1")
 358                            (type "ext4"))
 359                          (file-system
 360                            (mount-point (%store-prefix))
 361                            (device "store")
 362                            (type "9p")
 363                            (needed-for-boot? #t)
 364                            (options "trans=virtio")
 365                            (check? #f))
 366
 367                          ;; Remove file systems that conflict with those
 368                          ;; above, or that are normally bound to real devices.
 369                          (remove (lambda (fs)
 370                                    (let ((target (file-system-mount-point fs))
 371                                          (source (file-system-device fs)))
 372                                      (or (string=? target (%store-prefix))
 373                                          (string=? target "/")
 374                                          (string-prefix? "/dev/" source))))
 375                                  (operating-system-file-systems os))))))
 376
 377 (define* (system-qemu-image/shared-store
 378           os
 379           #:key
 380           full-boot?
 381           (disk-image-size (* (if full-boot? 500 15) (expt 2 20))))
 382   "Return a derivation that builds a QEMU image of OS that shares its store
 383 with the host.
 384
 385 When FULL-BOOT? is true, return an image that does a complete boot sequence,
 386 bootloaded included; thus, make a disk image that contains everything the
 387 bootloader refers to: OS kernel, initrd, bootloader data, etc."
 388   (mlet* %store-monad ((os-drv   (operating-system-derivation os))
 389                        (grub.cfg (operating-system-grub.cfg os)))
 390     ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
 391     ;; GRUB.CFG and all its dependencies, including the output of OS-DRV.
 392     ;; This is more than needed (we only need the kernel, initrd, GRUB for its
 393     ;; font, and the background image), but it's hard to filter that.
 394     (qemu-image #:os-derivation os-drv
 395                 #:grub-configuration grub.cfg
 396                 #:disk-image-size disk-image-size
 397                 #:inputs (if full-boot?
 398                              `(("grub.cfg" ,grub.cfg))
 399                              '())
 400
 401                 ;; XXX: Passing #t here is too slow, so let it off by default.
 402                 #:register-closures? #f
 403                 #:copy-inputs? full-boot?)))
 404
 405 (define* (common-qemu-options image)
 406   "Return the a string-value gexp with the common QEMU options to boot IMAGE."
 407 #~(string-append
 408      " -enable-kvm -no-reboot -net nic,model=virtio \
 409   -virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \
 410   -net user \
 411   -serial stdio \
 412   -drive file=" #$image
 413   ",if=virtio,cache=writeback,werror=report,readonly \
 414   -m 256"))
 415
 416 (define* (system-qemu-image/shared-store-script os
 417                                                 #:key
 418                                                 (qemu qemu)
 419                                                 (graphic? #t)
 420                                                 full-boot?
 421                                                 (disk-image-size
 422                                                  (* (if full-boot? 500 15)
 423                                                     (expt 2 20))))
 424   "Return a derivation that builds a script to run a virtual machine image of
 425 OS that shares its store with the host.
 426
 427 When FULL-BOOT? is true, the returned script runs everything starting from the
 428 bootloader; otherwise it directly starts the operating system kernel.  The
 429 DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
 430 it is mostly useful when FULL-BOOT?  is true."
 431   (mlet* %store-monad ((os ->  (virtualized-operating-system os))
 432                        (os-drv (operating-system-derivation os))
 433                        (image  (system-qemu-image/shared-store
 434                                 os
 435                                 #:full-boot? full-boot?
 436                                 #:disk-image-size disk-image-size)))
 437     (define builder
 438       #~(call-with-output-file #$output
 439           (lambda (port)
 440             (display
 441              (string-append "#!" #$bash "/bin/sh
 442 exec " #$qemu "/bin/" #$(qemu-command (%current-system))
 443
 444 #$@(if full-boot?
 445        #~()
 446        #~(" -kernel " #$(operating-system-kernel os) "/bzImage \
 447             -initrd " #$os-drv "/initrd \
 448             -append \"" #$(if graphic? "" "console=ttyS0 ")
 449             "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1\" "))
 450 #$(common-qemu-options image)
 451 " \"$@\"\n")
 452              port)
 453             (chmod port #o555))))
 454
 455     (gexp->derivation "run-vm.sh" builder)))
 456
 457 ;;; vm.scm ends here