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 packages base)
  27                 #:select (%final-inputs))
  28   #:use-module (gnu packages guile)
  29   #:use-module (gnu packages bash)
  30   #:use-module (gnu packages less)
  31   #:use-module (gnu packages qemu)
  32   #:use-module (gnu packages parted)
  33   #:use-module (gnu packages zile)
  34   #:use-module (gnu packages grub)
  35   #:use-module (gnu packages linux)
  36   #:use-module (gnu packages package-management)
  37   #:use-module ((gnu packages make-bootstrap)
  38                 #:select (%guile-static-stripped))
  39   #:use-module (gnu packages admin)
  40
  41   #:use-module (gnu system shadow)
  42   #:use-module (gnu system linux)
  43   #:use-module (gnu system linux-initrd)
  44   #:use-module (gnu system grub)
  45   #:use-module (gnu system)
  46   #:use-module (gnu services)
  47
  48   #:use-module (srfi srfi-1)
  49   #:use-module (srfi srfi-26)
  50   #:use-module (ice-9 match)
  51
  52   #:export (expression->derivation-in-linux-vm
  53             qemu-image
  54             system-qemu-image
  55             system-qemu-image/shared-store
  56             system-qemu-image/shared-store-script))
  57
  58 \f
  59 ;;; Commentary:
  60 ;;;
  61 ;;; Tools to evaluate build expressions within virtual machines.
  62 ;;;
  63 ;;; Code:
  64
  65 (define* (input->name+output tuple #:key (system (%current-system)))
  66   "Return as a monadic value a name/file-name pair corresponding to TUPLE, an
  67 input tuple.  The output file name is when building for SYSTEM."
  68   (with-monad %store-monad
  69     (match tuple
  70       ((input (? package? package))
  71        (mlet %store-monad ((out (package-file package #:system system)))
  72          (return `(,input . ,out))))
  73       ((input (? package? package) sub-drv)
  74        (mlet %store-monad ((out (package-file package
  75                                               #:output sub-drv
  76                                               #:system system)))
  77          (return `(,input . ,out))))
  78       ((input (? derivation? drv))
  79        (return `(,input . ,(derivation->output-path drv))))
  80       ((input (? derivation? drv) sub-drv)
  81        (return `(,input . ,(derivation->output-path drv sub-drv))))
  82       ((input (and (? string?) (? store-path?) file))
  83        (return `(,input . ,file))))))
  84
  85 (define %linux-vm-file-systems
  86   ;; File systems mounted for 'derivation-in-linux-vm'.  The store and /xchg
  87   ;; directory are shared with the host over 9p.
  88   (list (file-system
  89           (mount-point (%store-prefix))
  90           (device "store")
  91           (type "9p")
  92           (needed-for-boot? #t)
  93           (options "trans=virtio"))
  94         (file-system
  95           (mount-point "/xchg")
  96           (device "xchg")
  97           (type "9p")
  98           (needed-for-boot? #t)
  99           (options "trans=virtio"))))
 100
 101 (define* (expression->derivation-in-linux-vm name exp
 102                                              #:key
 103                                              (system (%current-system))
 104                                              (linux linux-libre)
 105                                              initrd
 106                                              (qemu qemu-headless)
 107                                              (env-vars '())
 108                                              (modules
 109                                               '((guix build vm)
 110                                                 (guix build linux-initrd)
 111                                                 (guix build utils)))
 112                                              (guile-for-build
 113                                               (%guile-for-build))
 114
 115                                              (make-disk-image? #f)
 116                                              (references-graphs #f)
 117                                              (memory-size 256)
 118                                              (disk-image-size
 119                                               (* 100 (expt 2 20))))
 120   "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
 121 derivation).  In the virtual machine, EXP has access to all its inputs from the
 122 store; it should put its output files in the `/xchg' directory, which is
 123 copied to the derivation's output when the VM terminates.  The virtual machine
 124 runs with MEMORY-SIZE MiB of memory.
 125
 126 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
 127 DISK-IMAGE-SIZE bytes and return it.
 128
 129 MODULES is the set of modules imported in the execution environment of EXP.
 130
 131 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 132 pairs, as for `derivation'.  The files containing the reference graphs are
 133 made available under the /xchg CIFS share."
 134   (mlet* %store-monad
 135       ((module-dir   (imported-modules modules))
 136        (compiled     (compiled-modules modules))
 137        (user-builder (gexp->file "builder-in-linux-vm" exp))
 138        (loader       (gexp->file "linux-vm-loader"
 139                                  #~(begin
 140                                      (set! %load-path
 141                                            (cons #$module-dir %load-path))
 142                                      (set! %load-compiled-path
 143                                            (cons #$compiled
 144                                                  %load-compiled-path))
 145                                      (primitive-load #$user-builder))))
 146        (coreutils -> (car (assoc-ref %final-inputs "coreutils")))
 147        (initrd       (if initrd                   ; use the default initrd?
 148                          (return initrd)
 149                          (qemu-initrd %linux-vm-file-systems
 150                                       #:guile-modules-in-chroot? #t))))
 151
 152     (define builder
 153       ;; Code that launches the VM that evaluates EXP.
 154       #~(begin
 155           (use-modules (guix build utils)
 156                        (guix 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-size #$disk-image-size
 174                               #:references-graphs graphs))))
 175
 176     (gexp->derivation name builder
 177                       ;; TODO: Require the "kvm" feature.
 178                       #:system system
 179                       #:env-vars env-vars
 180                       #:modules `((guix build utils)
 181                                   (guix build vm)
 182                                   (guix build linux-initrd))
 183                       #:guile-for-build guile-for-build
 184                       #:references-graphs references-graphs)))
 185
 186 (define* (qemu-image #:key
 187                      (name "qemu-image")
 188                      (system (%current-system))
 189                      (qemu qemu-headless)
 190                      (disk-image-size (* 100 (expt 2 20)))
 191                      (file-system-type "ext4")
 192                      grub-configuration
 193                      (initialize-store? #f)
 194                      (populate #f)
 195                      (inputs-to-copy '()))
 196   "Return a bootable, stand-alone QEMU image, with a root partition of type
 197 FILE-SYSTEM-TYPE.  The returned image is a full disk image, with a GRUB
 198 installation that uses GRUB-CONFIGURATION as its configuration
 199 file (GRUB-CONFIGURATION must be the name of a file in the VM.)
 200
 201 INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
 202 into the image being built.  When INITIALIZE-STORE? is true, initialize the
 203 store database in the image so that Guix can be used in the image.
 204
 205 POPULATE is a list of directives stating directories or symlinks to be created
 206 in the disk image partition.  It is evaluated once the image has been
 207 populated with INPUTS-TO-COPY.  It can be used to provide additional files,
 208 such as /etc files."
 209   (mlet %store-monad
 210       ((graph (sequence %store-monad
 211                         (map input->name+output inputs-to-copy))))
 212    (expression->derivation-in-linux-vm
 213     name
 214     #~(begin
 215         (use-modules (guix build vm)
 216                      (guix build utils))
 217
 218         (let ((inputs
 219                '#$(append (list qemu parted grub e2fsprogs util-linux)
 220                           (map (compose car (cut assoc-ref %final-inputs <>))
 221                                '("sed" "grep" "coreutils" "findutils" "gawk"))
 222                           (if initialize-store? (list guix) '())))
 223
 224               ;; This variable is unused but allows us to add INPUTS-TO-COPY
 225               ;; as inputs.
 226               (to-copy
 227                 '#$(map (match-lambda
 228                          ((name thing) thing)
 229                          ((name thing output) `(,thing ,output)))
 230                         inputs-to-copy)))
 231
 232           (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 233
 234           (let ((graphs '#$(match inputs-to-copy
 235                              (((names . _) ...)
 236                               names))))
 237             (initialize-hard-disk #:grub.cfg #$grub-configuration
 238                                   #:closures-to-copy graphs
 239                                   #:disk-image-size #$disk-image-size
 240                                   #:file-system-type #$file-system-type
 241                                   #:initialize-store? #$initialize-store?
 242                                   #:directives '#$populate)
 243             (reboot))))
 244     #:system system
 245     #:make-disk-image? #t
 246     #:disk-image-size disk-image-size
 247     #:references-graphs graph)))
 248
 249 \f
 250 ;;;
 251 ;;; Stand-alone VM image.
 252 ;;;
 253
 254 (define (operating-system-build-gid os)
 255   "Return as a monadic value the group id for build users of OS, or #f."
 256   (anym %store-monad
 257         (lambda (service)
 258           (and (equal? '(guix-daemon)
 259                        (service-provision service))
 260                (match (service-user-groups service)
 261                  ((group)
 262                   (user-group-id group)))))
 263         (operating-system-services os)))
 264
 265 (define (operating-system-default-contents os)
 266   "Return a list of directives suitable for 'system-qemu-image' describing the
 267 basic contents of the root file system of OS."
 268   (define (user-directories user)
 269     (let ((home (user-account-home-directory user))
 270           ;; XXX: Deal with automatically allocated ids.
 271           (uid  (or (user-account-uid user) 0))
 272           (gid  (or (user-account-gid user) 0))
 273           (root (string-append "/var/guix/profiles/per-user/"
 274                                (user-account-name user))))
 275       #~((directory #$root #$uid #$gid)
 276          (directory #$home #$uid #$gid))))
 277
 278   (mlet* %store-monad ((os-drv    (operating-system-derivation os))
 279                        (build-gid (operating-system-build-gid os))
 280                        (profile   (operating-system-profile os)))
 281     (return #~((directory #$(%store-prefix) 0 #$(or build-gid 0))
 282                (directory "/etc")
 283                (directory "/var/log")                     ; for dmd
 284                (directory "/var/run/nscd")
 285                (directory "/var/guix/gcroots")
 286                ("/var/guix/gcroots/system" -> #$os-drv)
 287                (directory "/run")
 288                ("/run/current-system" -> #$profile)
 289                (directory "/bin")
 290                ("/bin/sh" -> "/run/current-system/bin/bash")
 291                (directory "/tmp")
 292                (directory "/var/guix/profiles/per-user/root" 0 0)
 293
 294                (directory "/root" 0 0)             ; an exception
 295                #$@(append-map user-directories
 296                               (operating-system-users os))))))
 297
 298 (define* (system-qemu-image os
 299                             #:key (disk-image-size (* 900 (expt 2 20))))
 300   "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU
 301 system as described by OS."
 302   (mlet* %store-monad
 303       ((os-drv      (operating-system-derivation os))
 304        (os-dir   -> (derivation->output-path os-drv))
 305        (grub.cfg -> (string-append os-dir "/grub.cfg"))
 306        (populate    (operating-system-default-contents os)))
 307     (qemu-image  #:grub-configuration grub.cfg
 308                  #:populate populate
 309                  #:disk-image-size disk-image-size
 310                  #:initialize-store? #t
 311                  #:inputs-to-copy `(("system" ,os-drv)))))
 312
 313 (define (virtualized-operating-system os)
 314   "Return an operating system based on OS suitable for use in a virtualized
 315 environment with the store shared with the host."
 316   (operating-system (inherit os)
 317     (initrd (cut qemu-initrd <> #:volatile-root? #t))
 318     (file-systems (list (file-system
 319                           (mount-point "/")
 320                           (device "/dev/vda1")
 321                           (type "ext4"))
 322                         (file-system
 323                           (mount-point (%store-prefix))
 324                           (device "store")
 325                           (type "9p")
 326                           (needed-for-boot? #t)
 327                           (options "trans=virtio"))))))
 328
 329 (define* (system-qemu-image/shared-store
 330           os
 331           #:key (disk-image-size (* 15 (expt 2 20))))
 332   "Return a derivation that builds a QEMU image of OS that shares its store
 333 with the host."
 334   (mlet* %store-monad
 335       ((os-drv      (operating-system-derivation os))
 336        (os-dir   -> (derivation->output-path os-drv))
 337        (grub.cfg -> (string-append os-dir "/grub.cfg"))
 338        (populate    (operating-system-default-contents os)))
 339     ;; TODO: Initialize the database so Guix can be used in the guest.
 340     (qemu-image #:grub-configuration grub.cfg
 341                 #:populate populate
 342                 #:disk-image-size disk-image-size)))
 343
 344 (define* (system-qemu-image/shared-store-script
 345           os
 346           #:key
 347           (qemu qemu)
 348           (graphic? #t))
 349   "Return a derivation that builds a script to run a virtual machine image of
 350 OS that shares its store with the host."
 351   (mlet* %store-monad
 352       ((os ->  (virtualized-operating-system os))
 353        (os-drv (operating-system-derivation os))
 354        (image  (system-qemu-image/shared-store os)))
 355     (define builder
 356       #~(call-with-output-file #$output
 357           (lambda (port)
 358             (display
 359              (string-append "#!" #$bash "/bin/sh
 360 exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=virtio \
 361   -virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \
 362   -net user \
 363   -kernel " #$(operating-system-kernel os) "/bzImage \
 364   -initrd " #$os-drv "/initrd \
 365 -append \"" #$(if graphic? "" "console=ttyS0 ")
 366   "--load=" #$os-drv "/boot --root=/dev/vda1\" \
 367   -drive file=" #$image
 368   ",if=virtio,cache=writeback,werror=report,readonly\n")
 369              port)
 370             (chmod port #o555))))
 371
 372     (gexp->derivation "run-vm.sh" builder)))
 373
 374 ;;; vm.scm ends here