gnu/system/vm.scm

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