| 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 |
| 300 | (file-system-type "ext4") |
| 301 | (disk-image-size (* 900 (expt 2 20)))) |
| 302 | "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes |
| 303 | of the GNU system as described by OS." |
| 304 | (let ((os (operating-system (inherit os) |
| 305 | ;; The mounted file systems are under our control. |
| 306 | (file-systems (list (file-system |
| 307 | (mount-point "/") |
| 308 | (device "/dev/sda1") |
| 309 | (type file-system-type))))))) |
| 310 | (mlet* %store-monad |
| 311 | ((os-drv (operating-system-derivation os)) |
| 312 | (os-dir -> (derivation->output-path os-drv)) |
| 313 | (grub.cfg -> (string-append os-dir "/grub.cfg")) |
| 314 | (populate (operating-system-default-contents os))) |
| 315 | (qemu-image #:grub-configuration grub.cfg |
| 316 | #:populate populate |
| 317 | #:disk-image-size disk-image-size |
| 318 | #:file-system-type file-system-type |
| 319 | #:initialize-store? #t |
| 320 | #:inputs-to-copy `(("system" ,os-drv)))))) |
| 321 | |
| 322 | (define (virtualized-operating-system os) |
| 323 | "Return an operating system based on OS suitable for use in a virtualized |
| 324 | environment with the store shared with the host." |
| 325 | (operating-system (inherit os) |
| 326 | (initrd (cut qemu-initrd <> #:volatile-root? #t)) |
| 327 | (file-systems (list (file-system |
| 328 | (mount-point "/") |
| 329 | (device "/dev/vda1") |
| 330 | (type "ext4")) |
| 331 | (file-system |
| 332 | (mount-point (%store-prefix)) |
| 333 | (device "store") |
| 334 | (type "9p") |
| 335 | (needed-for-boot? #t) |
| 336 | (options "trans=virtio")))))) |
| 337 | |
| 338 | (define* (system-qemu-image/shared-store |
| 339 | os |
| 340 | #:key (disk-image-size (* 15 (expt 2 20)))) |
| 341 | "Return a derivation that builds a QEMU image of OS that shares its store |
| 342 | with the host." |
| 343 | (mlet* %store-monad |
| 344 | ((os-drv (operating-system-derivation os)) |
| 345 | (os-dir -> (derivation->output-path os-drv)) |
| 346 | (grub.cfg -> (string-append os-dir "/grub.cfg")) |
| 347 | (populate (operating-system-default-contents os))) |
| 348 | ;; TODO: Initialize the database so Guix can be used in the guest. |
| 349 | (qemu-image #:grub-configuration grub.cfg |
| 350 | #:populate populate |
| 351 | #:disk-image-size disk-image-size))) |
| 352 | |
| 353 | (define* (system-qemu-image/shared-store-script |
| 354 | os |
| 355 | #:key |
| 356 | (qemu qemu) |
| 357 | (graphic? #t)) |
| 358 | "Return a derivation that builds a script to run a virtual machine image of |
| 359 | OS that shares its store with the host." |
| 360 | (mlet* %store-monad |
| 361 | ((os -> (virtualized-operating-system os)) |
| 362 | (os-drv (operating-system-derivation os)) |
| 363 | (image (system-qemu-image/shared-store os))) |
| 364 | (define builder |
| 365 | #~(call-with-output-file #$output |
| 366 | (lambda (port) |
| 367 | (display |
| 368 | (string-append "#!" #$bash "/bin/sh |
| 369 | exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=virtio \ |
| 370 | -virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \ |
| 371 | -net user \ |
| 372 | -kernel " #$(operating-system-kernel os) "/bzImage \ |
| 373 | -initrd " #$os-drv "/initrd \ |
| 374 | -append \"" #$(if graphic? "" "console=ttyS0 ") |
| 375 | "--load=" #$os-drv "/boot --root=/dev/vda1\" \ |
| 376 | -drive file=" #$image |
| 377 | ",if=virtio,cache=writeback,werror=report,readonly\n") |
| 378 | port) |
| 379 | (chmod port #o555)))) |
| 380 | |
| 381 | (gexp->derivation "run-vm.sh" builder))) |
| 382 | |
| 383 | ;;; vm.scm ends here |