vm.scm 16 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org>
  4. ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
  5. ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
  6. ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
  7. ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
  8. ;;;
  9. ;;; This file is part of GNU Guix.
  10. ;;;
  11. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12. ;;; under the terms of the GNU General Public License as published by
  13. ;;; the Free Software Foundation; either version 3 of the License, or (at
  14. ;;; your option) any later version.
  15. ;;;
  16. ;;; GNU Guix is distributed in the hope that it will be useful, but
  17. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  19. ;;; GNU General Public License for more details.
  20. ;;;
  21. ;;; You should have received a copy of the GNU General Public License
  22. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  23. (define-module (gnu system vm)
  24. #:use-module (guix config)
  25. #:use-module (guix store)
  26. #:use-module (guix gexp)
  27. #:use-module (guix derivations)
  28. #:use-module (guix packages)
  29. #:use-module (guix monads)
  30. #:use-module (guix records)
  31. #:use-module (guix modules)
  32. #:use-module (guix utils)
  33. #:use-module (gcrypt hash)
  34. #:use-module (guix base32)
  35. #:use-module ((guix self) #:select (make-config.scm))
  36. #:use-module ((gnu build marionette)
  37. #:select (qemu-command))
  38. #:use-module (gnu packages base)
  39. #:use-module (gnu packages bootloaders)
  40. #:use-module (gnu packages cdrom)
  41. #:use-module (gnu packages compression)
  42. #:use-module (gnu packages guile)
  43. #:autoload (gnu packages gnupg) (guile-gcrypt)
  44. #:use-module (gnu packages gawk)
  45. #:use-module (gnu packages bash)
  46. #:use-module (gnu packages virtualization)
  47. #:use-module (gnu packages disk)
  48. #:use-module (gnu packages linux)
  49. #:use-module (gnu bootloader)
  50. #:use-module (gnu bootloader grub)
  51. #:use-module (gnu image)
  52. #:use-module (gnu system image)
  53. #:use-module (gnu system linux-container)
  54. #:use-module (gnu system linux-initrd)
  55. #:use-module (gnu bootloader)
  56. #:use-module (gnu system file-systems)
  57. #:use-module (gnu system)
  58. #:use-module (gnu services)
  59. #:use-module (gnu services base)
  60. #:use-module (gnu system uuid)
  61. #:use-module ((srfi srfi-1) #:hide (partition))
  62. #:use-module (srfi srfi-26)
  63. #:use-module (rnrs bytevectors)
  64. #:use-module (ice-9 match)
  65. #:export (virtualized-operating-system
  66. system-qemu-image/shared-store-script
  67. virtual-machine
  68. virtual-machine?))
  69. ;;; Commentary:
  70. ;;;
  71. ;;; Tools to evaluate build expressions within virtual machines.
  72. ;;;
  73. ;;; Code:
  74. ;; By default, the msize value is 8 KiB, which according to QEMU is
  75. ;; insufficient and would degrade performance. The msize value should roughly
  76. ;; match the bandwidth of the system's IO (see:
  77. ;; https://wiki.qemu.org/Documentation/9psetup#msize). Use 100 MiB as a
  78. ;; conservative default.
  79. (define %default-msize-value (* 100 (expt 2 20))) ;100 MiB
  80. (define %linux-vm-file-systems
  81. ;; File systems mounted for 'derivation-in-linux-vm'. These are shared with
  82. ;; the host over 9p.
  83. ;;
  84. ;; The 9p documentation says that cache=loose is "intended for exclusive,
  85. ;; read-only mounts", without additional details. It's much faster than the
  86. ;; default cache=none, especially when copying and registering store items.
  87. ;; Thus, use cache=loose, except for /xchg where we want to ensure
  88. ;; consistency.
  89. (list (file-system
  90. (mount-point (%store-prefix))
  91. (device "store")
  92. (type "9p")
  93. (needed-for-boot? #t)
  94. (flags '(read-only))
  95. (options (format #f "trans=virtio,cache=loose,msize=~a"
  96. %default-msize-value))
  97. (check? #f))
  98. (file-system
  99. (mount-point "/xchg")
  100. (device "xchg")
  101. (type "9p")
  102. (needed-for-boot? #t)
  103. (options (format #f "trans=virtio,msize=~a" %default-msize-value))
  104. (check? #f))
  105. (file-system
  106. (mount-point "/tmp")
  107. (device "tmp")
  108. (type "9p")
  109. (needed-for-boot? #t)
  110. (options (format #f "trans=virtio,cache=loose,msize=~a"
  111. %default-msize-value))
  112. (check? #f))))
  113. ;;;
  114. ;;; VMs that share file systems with the host.
  115. ;;;
  116. (define (file-system->mount-tag fs)
  117. "Return a 9p mount tag for host file system FS."
  118. ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain
  119. ;; slashes, and cannot start with '_'. Compute an identifier that
  120. ;; corresponds to the rules.
  121. (string-append "TAG"
  122. (string-drop (bytevector->base32-string
  123. (sha1 (string->utf8 fs)))
  124. 4)))
  125. (define (mapping->file-system mapping)
  126. "Return a 9p file system that realizes MAPPING."
  127. (match mapping
  128. (($ <file-system-mapping> source target writable?)
  129. (file-system
  130. (mount-point target)
  131. (device (file-system->mount-tag source))
  132. (type "9p")
  133. (flags (if writable? '() '(read-only)))
  134. (options (string-append "trans=virtio"
  135. (if writable? "" ",cache=loose")
  136. ",msize=" (number->string %default-msize-value)))
  137. (check? #f)
  138. (create-mount-point? #t)))))
  139. (define* (virtualized-operating-system os mappings
  140. #:key (full-boot? #f) volatile?)
  141. "Return an operating system based on OS suitable for use in a virtualized
  142. environment with the store shared with the host. MAPPINGS is a list of
  143. <file-system-mapping> to realize in the virtualized OS."
  144. (define user-file-systems
  145. ;; Remove file systems that conflict with those added below, or that are
  146. ;; normally bound to real devices.
  147. (remove (lambda (fs)
  148. (let ((target (file-system-mount-point fs))
  149. (source (file-system-device fs)))
  150. (or (string=? target (%store-prefix))
  151. (string=? target "/")
  152. (and (string? source)
  153. (string-prefix? "/dev/" source))
  154. ;; Labels and UUIDs are necessarily invalid in the VM.
  155. (and (file-system-mount? fs)
  156. (or (file-system-label? source)
  157. (uuid? source))))))
  158. (operating-system-file-systems os)))
  159. (define virtual-file-systems
  160. (cons (file-system
  161. (mount-point "/")
  162. (device "/dev/vda1")
  163. (type "ext4"))
  164. (append (map mapping->file-system mappings)
  165. user-file-systems)))
  166. (operating-system (inherit os)
  167. ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware),
  168. ;; force the traditional i386/BIOS method.
  169. ;; See <https://bugs.gnu.org/28768>.
  170. (bootloader (bootloader-configuration
  171. (inherit (operating-system-bootloader os))
  172. (bootloader grub-bootloader)
  173. (targets '("/dev/vda"))))
  174. (initrd (lambda (file-systems . rest)
  175. (apply (operating-system-initrd os)
  176. file-systems
  177. #:volatile-root? volatile?
  178. rest)))
  179. ;; Disable swap.
  180. (swap-devices '())
  181. ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
  182. ;; since that would lead the bootloader config to look for the kernel and
  183. ;; initrd in it.
  184. (file-systems (if full-boot?
  185. virtual-file-systems
  186. (cons
  187. (file-system
  188. (inherit (mapping->file-system %store-mapping))
  189. (needed-for-boot? #t))
  190. virtual-file-systems)))))
  191. (define* (common-qemu-options image shared-fs
  192. #:key rw-image?)
  193. "Return the a string-value gexp with the common QEMU options to boot IMAGE,
  194. with '-virtfs' options for the host file systems listed in SHARED-FS."
  195. (define (virtfs-option fs)
  196. #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
  197. #$fs #$(file-system->mount-tag fs)))
  198. #~(;; Only enable kvm if we see /dev/kvm exists.
  199. ;; This allows users without hardware virtualization to still use these
  200. ;; commands.
  201. #$@(if (file-exists? "/dev/kvm")
  202. '("-enable-kvm")
  203. '())
  204. "-no-reboot"
  205. "-object" "rng-random,filename=/dev/urandom,id=guix-vm-rng"
  206. "-device" "virtio-rng-pci,rng=guix-vm-rng"
  207. #$@(map virtfs-option shared-fs)
  208. #$@(if rw-image?
  209. #~((format #f "-drive file=~a,if=virtio" #$image))
  210. #~((format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly=on"
  211. #$image)))))
  212. (define* (system-qemu-image/shared-store-script os
  213. #:key
  214. (system (%current-system))
  215. (target (%current-target-system))
  216. (qemu qemu)
  217. (graphic? #t)
  218. (volatile? #t)
  219. (memory-size 512)
  220. (mappings '())
  221. full-boot?
  222. (disk-image-size
  223. (* (if full-boot? 500 70)
  224. (expt 2 20)))
  225. (options '()))
  226. "Return a derivation that builds a script to run a virtual machine image of
  227. OS that shares its store with the host. The virtual machine runs with
  228. MEMORY-SIZE MiB of memory.
  229. MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
  230. systems into the guest.
  231. When FULL-BOOT? is true, the returned script runs everything starting from the
  232. bootloader; otherwise it directly starts the operating system kernel. When
  233. VOLATILE? is true, an overlay is created on top of a read-only
  234. storage. Otherwise the storage is made persistent. The DISK-IMAGE-SIZE
  235. parameter specifies the size in bytes of the root disk image; it is mostly
  236. useful when FULL-BOOT? is true."
  237. (mlet* %store-monad ((os -> (virtualized-operating-system
  238. os mappings
  239. #:full-boot? full-boot?
  240. #:volatile? volatile?))
  241. (base-image -> (system-image
  242. (image
  243. (inherit
  244. (raw-with-offset-disk-image))
  245. (operating-system os)
  246. (size disk-image-size)
  247. (shared-store?
  248. (and (not full-boot?) volatile?))
  249. (volatile-root? volatile?)))))
  250. (define kernel-arguments
  251. #~(list #$@(if graphic? #~() #~("console=ttyS0"))
  252. #+@(operating-system-kernel-arguments os "/dev/vda1")))
  253. (define rw-image
  254. #~(format #f "/tmp/guix-image-~a" (basename #$base-image)))
  255. (define qemu-exec
  256. #~(list #+(file-append qemu "/bin/"
  257. (qemu-command (or target system)))
  258. ;; Tells qemu to use the terminal it was started in for IO.
  259. #$@(if graphic? '() #~("-nographic"))
  260. #$@(if full-boot?
  261. #~()
  262. #~("-kernel" #$(operating-system-kernel-file os)
  263. "-initrd" #$(file-append os "/initrd")
  264. (format #f "-append ~s"
  265. (string-join #$kernel-arguments " "))))
  266. #$@(common-qemu-options (if volatile? base-image rw-image)
  267. (map file-system-mapping-source
  268. (cons %store-mapping mappings))
  269. #:rw-image? (not volatile?))
  270. "-m " (number->string #$memory-size)
  271. #$@options))
  272. (define builder
  273. #~(call-with-output-file #$output
  274. (lambda (port)
  275. (format port "#!~a~%"
  276. #+(file-append bash "/bin/sh"))
  277. (when (not #$volatile?)
  278. (format port "~a~%"
  279. #$(program-file "copy-image"
  280. #~(unless (file-exists? #$rw-image)
  281. (copy-file #$base-image #$rw-image)
  282. (chmod #$rw-image #o640)))))
  283. (format port "exec ~a \"$@\"~%"
  284. (string-join #$qemu-exec " "))
  285. (chmod port #o555))))
  286. (gexp->derivation "run-vm.sh" builder)))
  287. ;;;
  288. ;;; High-level abstraction.
  289. ;;;
  290. (define-record-type* <virtual-machine> %virtual-machine
  291. make-virtual-machine
  292. virtual-machine?
  293. (operating-system virtual-machine-operating-system) ;<operating-system>
  294. (qemu virtual-machine-qemu ;<package>
  295. (default qemu-minimal))
  296. (volatile? virtual-machine-volatile? ;Boolean
  297. (default #t))
  298. (graphic? virtual-machine-graphic? ;Boolean
  299. (default #f))
  300. (memory-size virtual-machine-memory-size ;integer (MiB)
  301. (default 256))
  302. (disk-image-size virtual-machine-disk-image-size ;integer (bytes)
  303. (default 'guess))
  304. (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
  305. (default '())))
  306. (define-syntax virtual-machine
  307. (syntax-rules ()
  308. "Declare a virtual machine running the specified OS, with the given
  309. options."
  310. ((_ os) ;shortcut
  311. (%virtual-machine (operating-system os)))
  312. ((_ fields ...)
  313. (%virtual-machine fields ...))))
  314. (define (port-forwardings->qemu-options forwardings)
  315. "Return the QEMU option for the given port FORWARDINGS as a string, where
  316. FORWARDINGS is a list of host-port/guest-port pairs."
  317. (string-join
  318. (map (match-lambda
  319. ((host-port . guest-port)
  320. (string-append "hostfwd=tcp::"
  321. (number->string host-port)
  322. "-:" (number->string guest-port))))
  323. forwardings)
  324. ","))
  325. (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
  326. system target)
  327. (match vm
  328. (($ <virtual-machine> os qemu volatile? graphic? memory-size
  329. disk-image-size ())
  330. (system-qemu-image/shared-store-script os
  331. #:system system
  332. #:target target
  333. #:qemu qemu
  334. #:graphic? graphic?
  335. #:volatile? volatile?
  336. #:memory-size memory-size
  337. #:disk-image-size
  338. disk-image-size))
  339. (($ <virtual-machine> os qemu volatile? graphic? memory-size
  340. disk-image-size forwardings)
  341. (let ((options
  342. `("-nic" ,(string-append
  343. "user,model=virtio-net-pci,"
  344. (port-forwardings->qemu-options forwardings)))))
  345. (system-qemu-image/shared-store-script os
  346. #:system system
  347. #:target target
  348. #:qemu qemu
  349. #:graphic? graphic?
  350. #:volatile? volatile?
  351. #:memory-size memory-size
  352. #:disk-image-size
  353. disk-image-size
  354. #:options options)))))
  355. ;;; vm.scm ends here