You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

963 lines
42 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2016 Christopher Allan 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 scripts pack)
  33. #:use-module (guix utils)
  34. #:use-module (gcrypt hash)
  35. #:use-module (guix base32)
  36. #:use-module ((guix self) #:select (make-config.scm))
  37. #:use-module ((gnu build vm)
  38. #:select (qemu-command))
  39. #:use-module (gnu packages base)
  40. #:use-module (gnu packages bootloaders)
  41. #:use-module (gnu packages cdrom)
  42. #:use-module (gnu packages compression)
  43. #:use-module (gnu packages guile)
  44. #:autoload (gnu packages gnupg) (guile-gcrypt)
  45. #:use-module (gnu packages gawk)
  46. #:use-module (gnu packages bash)
  47. #:use-module (gnu packages less)
  48. #:use-module (gnu packages virtualization)
  49. #:use-module (gnu packages disk)
  50. #:use-module (gnu packages zile)
  51. #:use-module (gnu packages linux)
  52. #:use-module ((gnu packages make-bootstrap)
  53. #:select (%guile-static-stripped))
  54. #:use-module (gnu packages admin)
  55. #:use-module (gnu bootloader)
  56. #:use-module (gnu bootloader grub)
  57. #:use-module (gnu system shadow)
  58. #:use-module (gnu system pam)
  59. #:use-module (gnu system linux-initrd)
  60. #:use-module (gnu bootloader)
  61. #:use-module (gnu system file-systems)
  62. #:use-module (gnu system)
  63. #:use-module (gnu services)
  64. #:use-module (gnu system uuid)
  65. #:use-module (srfi srfi-1)
  66. #:use-module (srfi srfi-26)
  67. #:use-module (rnrs bytevectors)
  68. #:use-module (ice-9 match)
  69. #:export (expression->derivation-in-linux-vm
  70. qemu-image
  71. virtualized-operating-system
  72. system-qemu-image
  73. system-qemu-image/shared-store
  74. system-qemu-image/shared-store-script
  75. system-disk-image
  76. system-docker-image
  77. virtual-machine
  78. virtual-machine?))
  79. ;;; Commentary:
  80. ;;;
  81. ;;; Tools to evaluate build expressions within virtual machines.
  82. ;;;
  83. ;;; Code:
  84. (define %linux-vm-file-systems
  85. ;; File systems mounted for 'derivation-in-linux-vm'. These are shared with
  86. ;; the host over 9p.
  87. (list (file-system
  88. (mount-point (%store-prefix))
  89. (device "store")
  90. (type "9p")
  91. (needed-for-boot? #t)
  92. (options "trans=virtio")
  93. (check? #f))
  94. (file-system
  95. (mount-point "/xchg")
  96. (device "xchg")
  97. (type "9p")
  98. (needed-for-boot? #t)
  99. (options "trans=virtio")
  100. (check? #f))
  101. (file-system
  102. (mount-point "/tmp")
  103. (device "tmp")
  104. (type "9p")
  105. (needed-for-boot? #t)
  106. (options "trans=virtio")
  107. (check? #f))))
  108. (define not-config?
  109. ;; Select (guix …) and (gnu …) modules, except (guix config).
  110. (match-lambda
  111. (('guix 'config) #f)
  112. (('guix rest ...) #t)
  113. (('gnu rest ...) #t)
  114. (rest #f)))
  115. (define gcrypt-sqlite3&co
  116. ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
  117. (append-map (lambda (package)
  118. (cons package
  119. (package-transitive-propagated-inputs package)))
  120. (list guile-gcrypt guile-sqlite3)))
  121. (define* (expression->derivation-in-linux-vm name exp
  122. #:key
  123. (system (%current-system))
  124. (linux linux-libre)
  125. initrd
  126. (qemu qemu-minimal)
  127. (env-vars '())
  128. (guile-for-build
  129. (%guile-for-build))
  130. (file-systems
  131. %linux-vm-file-systems)
  132. (single-file-output? #f)
  133. (make-disk-image? #f)
  134. (references-graphs #f)
  135. (memory-size 256)
  136. (disk-image-format "qcow2")
  137. (disk-image-size 'guess))
  138. "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
  139. derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the
  140. virtual machine, EXP has access to FILE-SYSTEMS, which, by default, includes a
  141. 9p share of the store, the '/xchg' where EXP should put its output file(s),
  142. and a 9p share of /tmp.
  143. If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
  144. Otherwise, copy the contents of /xchg to a new directory OUTPUT.
  145. When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
  146. DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
  147. return it. When DISK-IMAGE-SIZE is 'guess, estimate the image size based
  148. based on the size of the closure of REFERENCES-GRAPHS.
  149. When REFERENCES-GRAPHS is true, it must be a list of file name/store path
  150. pairs, as for `derivation'. The files containing the reference graphs are
  151. made available under the /xchg CIFS share."
  152. (define user-builder
  153. (program-file "builder-in-linux-vm" exp))
  154. (define loader
  155. ;; Invoke USER-BUILDER instead using 'primitive-load'. The reason for
  156. ;; this is to allow USER-BUILDER to dlopen stuff by using a full-featured
  157. ;; Guile, which it couldn't do using the statically-linked guile used in
  158. ;; the initrd. See example at
  159. ;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>.
  160. (program-file "linux-vm-loader"
  161. ;; When USER-BUILDER succeeds, reboot (indicating a
  162. ;; success), otherwise die, which causes a kernel panic
  163. ;; ("Attempted to kill init!").
  164. #~(when (zero? (system* #$user-builder))
  165. (reboot))))
  166. (mlet* %store-monad
  167. ((initrd (if initrd ; use the default initrd?
  168. (return initrd)
  169. (base-initrd file-systems
  170. #:on-error 'backtrace
  171. #:linux linux
  172. #:linux-modules %base-initrd-modules
  173. #:qemu-networking? #t))))
  174. (define builder
  175. ;; Code that launches the VM that evaluates EXP.
  176. (with-extensions gcrypt-sqlite3&co
  177. (with-imported-modules `(,@(source-module-closure
  178. '((guix build utils)
  179. (gnu build vm))
  180. #:select? not-config?)
  181. ;; For consumption by (gnu store database).
  182. ((guix config) => ,(make-config.scm)))
  183. #~(begin
  184. (use-modules (guix build utils)
  185. (gnu build vm))
  186. (let* ((inputs '#$(list qemu (canonical-package coreutils)))
  187. (linux (string-append #$linux "/"
  188. #$(system-linux-image-file-name)))
  189. (initrd (string-append #$initrd "/initrd"))
  190. (loader #$loader)
  191. (graphs '#$(match references-graphs
  192. (((graph-files . _) ...) graph-files)
  193. (_ #f)))
  194. (size #$(if (eq? 'guess disk-image-size)
  195. #~(+ (* 70 (expt 2 20)) ;ESP
  196. (estimated-partition-size graphs))
  197. disk-image-size)))
  198. (set-path-environment-variable "PATH" '("bin") inputs)
  199. (load-in-linux-vm loader
  200. #:output #$output
  201. #:linux linux #:initrd initrd
  202. #:memory-size #$memory-size
  203. #:make-disk-image? #$make-disk-image?
  204. #:single-file-output? #$single-file-output?
  205. ;; FIXME: ‘target-arm32?’ may not operate on
  206. ;; the right system/target values. Rewrite
  207. ;; using ‘let-system’ when available.
  208. #:target-arm32? #$(target-arm32?)
  209. #:disk-image-format #$disk-image-format
  210. #:disk-image-size size
  211. #:references-graphs graphs))))))
  212. (gexp->derivation name builder
  213. ;; TODO: Require the "kvm" feature.
  214. #:system system
  215. #:env-vars env-vars
  216. #:guile-for-build guile-for-build
  217. #:references-graphs references-graphs)))
  218. (define* (iso9660-image #:key
  219. (name "iso9660-image")
  220. file-system-label
  221. file-system-uuid
  222. (system (%current-system))
  223. (qemu qemu-minimal)
  224. os-drv
  225. bootcfg-drv
  226. bootloader
  227. register-closures?
  228. (inputs '()))
  229. "Return a bootable, stand-alone iso9660 image.
  230. INPUTS is a list of inputs (as for packages)."
  231. (define schema
  232. (and register-closures?
  233. (local-file (search-path %load-path
  234. "guix/store/schema.sql"))))
  235. (expression->derivation-in-linux-vm
  236. name
  237. (with-extensions gcrypt-sqlite3&co
  238. (with-imported-modules `(,@(source-module-closure '((gnu build vm)
  239. (guix store database)
  240. (guix build utils))
  241. #:select? not-config?)
  242. ((guix config) => ,(make-config.scm)))
  243. #~(begin
  244. (use-modules (gnu build vm)
  245. (guix store database)
  246. (guix build utils))
  247. (sql-schema #$schema)
  248. (let ((inputs
  249. '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
  250. (map canonical-package
  251. (list sed grep coreutils findutils gawk))))
  252. (graphs '#$(match inputs
  253. (((names . _) ...)
  254. names)))
  255. ;; This variable is unused but allows us to add INPUTS-TO-COPY
  256. ;; as inputs.
  257. (to-register
  258. '#$(map (match-lambda
  259. ((name thing) thing)
  260. ((name thing output) `(,thing ,output)))
  261. inputs)))
  262. (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
  263. (make-iso9660-image #$(bootloader-package bootloader)
  264. #$bootcfg-drv
  265. #$os-drv
  266. "/xchg/guixsd.iso"
  267. #:register-closures? #$register-closures?
  268. #:closures graphs
  269. #:volume-id #$file-system-label
  270. #:volume-uuid #$(and=> file-system-uuid
  271. uuid-bytevector))))))
  272. #:system system
  273. ;; Keep a local file system for /tmp so that we can populate it directly as
  274. ;; root and have files owned by root. See <https://bugs.gnu.org/31752>.
  275. #:file-systems (remove (lambda (file-system)
  276. (string=? (file-system-mount-point file-system)
  277. "/tmp"))
  278. %linux-vm-file-systems)
  279. #:make-disk-image? #f
  280. #:single-file-output? #t
  281. #:references-graphs inputs))
  282. (define* (qemu-image #:key
  283. (name "qemu-image")
  284. (system (%current-system))
  285. (qemu qemu-minimal)
  286. (disk-image-size 'guess)
  287. (disk-image-format "qcow2")
  288. (file-system-type "ext4")
  289. file-system-label
  290. file-system-uuid
  291. os-drv
  292. bootcfg-drv
  293. bootloader
  294. (register-closures? #t)
  295. (inputs '())
  296. copy-inputs?)
  297. "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
  298. 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
  299. Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
  300. partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
  301. partition (a UUID object).
  302. The returned image is a full disk image that runs OS-DERIVATION,
  303. with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
  304. file (GRUB-CONFIGURATION must be the name of a file in the VM.)
  305. INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
  306. all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
  307. register INPUTS in the store database of the image so that Guix can be used in
  308. the image."
  309. (define schema
  310. (and register-closures?
  311. (local-file (search-path %load-path
  312. "guix/store/schema.sql"))))
  313. (expression->derivation-in-linux-vm
  314. name
  315. (with-extensions gcrypt-sqlite3&co
  316. (with-imported-modules `(,@(source-module-closure '((gnu build vm)
  317. (gnu build bootloader)
  318. (guix store database)
  319. (guix build utils))
  320. #:select? not-config?)
  321. ((guix config) => ,(make-config.scm)))
  322. #~(begin
  323. (use-modules (gnu build bootloader)
  324. (gnu build vm)
  325. (guix store database)
  326. (guix build utils)
  327. (srfi srfi-26)
  328. (ice-9 binary-ports))
  329. (sql-schema #$schema)
  330. (let ((inputs
  331. '#$(append (list qemu parted e2fsprogs dosfstools)
  332. (map canonical-package
  333. (list sed grep coreutils findutils gawk))))
  334. ;; This variable is unused but allows us to add INPUTS-TO-COPY
  335. ;; as inputs.
  336. (to-register
  337. '#$(map (match-lambda
  338. ((name thing) thing)
  339. ((name thing output) `(,thing ,output)))
  340. inputs)))
  341. (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
  342. (let* ((graphs '#$(match inputs
  343. (((names . _) ...)
  344. names)))
  345. (initialize (root-partition-initializer
  346. #:closures graphs
  347. #:copy-closures? #$copy-inputs?
  348. #:register-closures? #$register-closures?
  349. #:system-directory #$os-drv))
  350. (root-size #$(if (eq? 'guess disk-image-size)
  351. #~(max
  352. ;; Minimum 20 MiB root size
  353. (* 20 (expt 2 20))
  354. (estimated-partition-size
  355. (map (cut string-append "/xchg/" <>)
  356. graphs)))
  357. (- disk-image-size
  358. (* 50 (expt 2 20)))))
  359. (partitions
  360. (append
  361. (list (partition
  362. (size root-size)
  363. (label #$file-system-label)
  364. (uuid #$(and=> file-system-uuid
  365. uuid-bytevector))
  366. (file-system #$file-system-type)
  367. (flags '(boot))
  368. (initializer initialize)))
  369. ;; Append a small EFI System Partition for use with UEFI
  370. ;; bootloaders if we are not targeting ARM because UEFI
  371. ;; support in U-Boot is experimental.
  372. ;;
  373. ;; FIXME: ‘target-arm32?’ may be not operate on the right
  374. ;; system/target values. Rewrite using ‘let-system’ when
  375. ;; available.
  376. (if #$(target-arm32?)
  377. '()
  378. (list (partition
  379. ;; The standalone grub image is about 10MiB, but
  380. ;; leave some room for custom or multiple images.
  381. (size (* 40 (expt 2 20)))
  382. (label "GNU-ESP") ;cosmetic only
  383. ;; Use "vfat" here since this property is used
  384. ;; when mounting. The actual FAT-ness is based
  385. ;; on file system size (16 in this case).
  386. (file-system "vfat")
  387. (flags '(esp))))))))
  388. (initialize-hard-disk "/dev/vda"
  389. #:partitions partitions
  390. #:grub-efi #$grub-efi
  391. #:bootloader-package
  392. #$(bootloader-package bootloader)
  393. #:bootcfg #$bootcfg-drv
  394. #:bootcfg-location
  395. #$(bootloader-configuration-file bootloader)
  396. #:bootloader-installer
  397. #$(bootloader-installer bootloader)))))))
  398. #:system system
  399. #:make-disk-image? #t
  400. #:disk-image-size disk-image-size
  401. #:disk-image-format disk-image-format
  402. #:references-graphs inputs))
  403. (define* (system-docker-image os
  404. #:key
  405. (name "guixsd-docker-image")
  406. register-closures?)
  407. "Build a docker image. OS is the desired <operating-system>. NAME is the
  408. base name to use for the output file. When REGISTER-CLOSURES? is not #f,
  409. register the closure of OS with Guix in the resulting Docker image. This only
  410. makes sense when you want to build a GuixSD Docker image that has Guix
  411. installed inside of it. If you don't need Guix (e.g., your GuixSD Docker
  412. image just contains a web server that is started by the Shepherd), then you
  413. should set REGISTER-CLOSURES? to #f."
  414. (define schema
  415. (and register-closures?
  416. (local-file (search-path %load-path
  417. "guix/store/schema.sql"))))
  418. (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
  419. (name -> (string-append name ".tar.gz"))
  420. (graph -> "system-graph"))
  421. (define build
  422. (with-extensions (cons guile-json ;for (guix docker)
  423. gcrypt-sqlite3&co) ;for (guix store database)
  424. (with-imported-modules `(,@(source-module-closure
  425. '((guix docker)
  426. (guix store database)
  427. (guix build utils)
  428. (guix build store-copy)
  429. (gnu build vm))
  430. #:select? not-config?)
  431. ((guix config) => ,(make-config.scm)))
  432. #~(begin
  433. (use-modules (guix docker)
  434. (guix build utils)
  435. (gnu build vm)
  436. (srfi srfi-19)
  437. (guix build store-copy)
  438. (guix store database))
  439. ;; Set the SQL schema location.
  440. (sql-schema #$schema)
  441. (let* (;; This initializer requires elevated privileges that are
  442. ;; not normally available in the build environment (e.g.,
  443. ;; it needs to create device nodes). In order to obtain
  444. ;; such privileges, we run it as root in a VM.
  445. (initialize (root-partition-initializer
  446. #:closures '(#$graph)
  447. #:register-closures? #$register-closures?
  448. #:system-directory #$os-drv
  449. ;; De-duplication would fail due to
  450. ;; cross-device link errors, so don't do it.
  451. #:deduplicate? #f))
  452. ;; Even as root in a VM, the initializer would fail due to
  453. ;; lack of privileges if we use a root-directory that is on
  454. ;; a file system that is shared with the host (e.g., /tmp).
  455. (root-directory "/guixsd-system-root"))
  456. (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
  457. (mkdir root-directory)
  458. (initialize root-directory)
  459. (build-docker-image
  460. (string-append "/xchg/" #$name) ;; The output file.
  461. (cons* root-directory
  462. (map store-info-item
  463. (call-with-input-file
  464. (string-append "/xchg/" #$graph)
  465. read-reference-graph)))
  466. #$os-drv
  467. #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
  468. #:creation-time (make-time time-utc 0 1)
  469. #:transformations `((,root-directory -> ""))))))))
  470. (expression->derivation-in-linux-vm
  471. name build
  472. #:make-disk-image? #f
  473. #:single-file-output? #t
  474. #:references-graphs `((,graph ,os-drv)))))
  475. ;;;
  476. ;;; VM and disk images.
  477. ;;;
  478. (define* (operating-system-uuid os #:optional (type 'dce))
  479. "Compute UUID object with a deterministic \"UUID\" for OS, of the given
  480. TYPE (one of 'iso9660 or 'dce). Return a UUID object."
  481. (if (eq? type 'iso9660)
  482. (let ((pad (compose (cut string-pad <> 2 #\0)
  483. number->string))
  484. (h (hash (operating-system-services os) 3600)))
  485. (bytevector->uuid
  486. (string->iso9660-uuid
  487. (string-append "1970-01-01-"
  488. (pad (hash (operating-system-host-name os) 24)) "-"
  489. (pad (quotient h 60)) "-"
  490. (pad (modulo h 60)) "-"
  491. (pad (hash (operating-system-file-systems os) 100))))
  492. 'iso9660))
  493. (bytevector->uuid
  494. (uint-list->bytevector
  495. (list (hash file-system-type
  496. (- (expt 2 32) 1))
  497. (hash (operating-system-host-name os)
  498. (- (expt 2 32) 1))
  499. (hash (operating-system-services os)
  500. (- (expt 2 32) 1))
  501. (hash (operating-system-file-systems os)
  502. (- (expt 2 32) 1)))
  503. (endianness little)
  504. 4)
  505. type)))
  506. (define* (system-disk-image os
  507. #:key
  508. (name "disk-image")
  509. (file-system-type "ext4")
  510. (disk-image-size (* 900 (expt 2 20)))
  511. (volatile? #t))
  512. "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
  513. system described by OS. Said image can be copied on a USB stick as is. When
  514. VOLATILE? is true, the root file system is made volatile; this is useful
  515. to USB sticks meant to be read-only."
  516. (define normalize-label
  517. ;; ISO labels are all-caps (case-insensitive), but since
  518. ;; 'find-partition-by-label' is case-sensitive, make it all-caps here.
  519. (if (string=? "iso9660" file-system-type)
  520. string-upcase
  521. identity))
  522. (define root-label
  523. ;; Volume name of the root file system.
  524. (normalize-label "GuixSD_image"))
  525. (define root-uuid
  526. ;; UUID of the root file system, computed in a deterministic fashion.
  527. ;; This is what we use to locate the root file system so it has to be
  528. ;; different from the user's own file system UUIDs.
  529. (operating-system-uuid os
  530. (if (string=? file-system-type "iso9660")
  531. 'iso9660
  532. 'dce)))
  533. (define file-systems-to-keep
  534. (remove (lambda (fs)
  535. (string=? (file-system-mount-point fs) "/"))
  536. (operating-system-file-systems os)))
  537. (let ((os (operating-system (inherit os)
  538. ;; Since this is meant to be used on real hardware, don't
  539. ;; install QEMU networking or anything like that. Assume USB
  540. ;; mass storage devices (usb-storage.ko) are available.
  541. (initrd (lambda (file-systems . rest)
  542. (apply (operating-system-initrd os)
  543. file-systems
  544. #:volatile-root? #t
  545. rest)))
  546. (bootloader (if (string=? "iso9660" file-system-type)
  547. (bootloader-configuration
  548. (inherit (operating-system-bootloader os))
  549. (bootloader grub-mkrescue-bootloader))
  550. (operating-system-bootloader os)))
  551. ;; Force our own root file system.
  552. (file-systems (cons (file-system
  553. (mount-point "/")
  554. (device root-uuid)
  555. (type file-system-type))
  556. file-systems-to-keep)))))
  557. (mlet* %store-monad ((os-drv (operating-system-derivation os))
  558. (bootcfg (operating-system-bootcfg os)))
  559. (if (string=? "iso9660" file-system-type)
  560. (iso9660-image #:name name
  561. #:file-system-label root-label
  562. #:file-system-uuid root-uuid
  563. #:os-drv os-drv
  564. #:register-closures? #t
  565. #:bootcfg-drv bootcfg
  566. #:bootloader (bootloader-configuration-bootloader
  567. (operating-system-bootloader os))
  568. #:inputs `(("system" ,os-drv)
  569. ("bootcfg" ,bootcfg)))
  570. (qemu-image #:name name
  571. #:os-drv os-drv
  572. #:bootcfg-drv bootcfg
  573. #:bootloader (bootloader-configuration-bootloader
  574. (operating-system-bootloader os))
  575. #:disk-image-size disk-image-size
  576. #:disk-image-format "raw"
  577. #:file-system-type file-system-type
  578. #:file-system-label root-label
  579. #:file-system-uuid root-uuid
  580. #:copy-inputs? #t
  581. #:register-closures? #t
  582. #:inputs `(("system" ,os-drv)
  583. ("bootcfg" ,bootcfg)))))))
  584. (define* (system-qemu-image os
  585. #:key
  586. (file-system-type "ext4")
  587. (disk-image-size (* 900 (expt 2 20))))
  588. "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
  589. of the GNU system as described by OS."
  590. (define file-systems-to-keep
  591. ;; Keep only file systems other than root and not normally bound to real
  592. ;; devices.
  593. (remove (lambda (fs)
  594. (let ((target (file-system-mount-point fs))
  595. (source (file-system-device fs)))
  596. (or (string=? target "/")
  597. (string-prefix? "/dev/" source))))
  598. (operating-system-file-systems os)))
  599. (define root-uuid
  600. ;; UUID of the root file system.
  601. (operating-system-uuid os
  602. (if (string=? file-system-type "iso9660")
  603. 'iso9660
  604. 'dce)))
  605. (let ((os (operating-system (inherit os)
  606. ;; Assume we have an initrd with the whole QEMU shebang.
  607. ;; Force our own root file system. Refer to it by UUID so that
  608. ;; it works regardless of how the image is used ("qemu -hda",
  609. ;; Xen, etc.).
  610. (file-systems (cons (file-system
  611. (mount-point "/")
  612. (device root-uuid)
  613. (type file-system-type))
  614. file-systems-to-keep)))))
  615. (mlet* %store-monad
  616. ((os-drv (operating-system-derivation os))
  617. (bootcfg (operating-system-bootcfg os)))
  618. (qemu-image #:os-drv os-drv
  619. #:bootcfg-drv bootcfg
  620. #:bootloader (bootloader-configuration-bootloader
  621. (operating-system-bootloader os))
  622. #:disk-image-size disk-image-size
  623. #:file-system-type file-system-type
  624. #:file-system-uuid root-uuid
  625. #:inputs `(("system" ,os-drv)
  626. ("bootcfg" ,bootcfg))
  627. #:copy-inputs? #t))))
  628. ;;;
  629. ;;; VMs that share file systems with the host.
  630. ;;;
  631. (define (file-system->mount-tag fs)
  632. "Return a 9p mount tag for host file system FS."
  633. ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain
  634. ;; slashes, and cannot start with '_'. Compute an identifier that
  635. ;; corresponds to the rules.
  636. (string-append "TAG"
  637. (string-drop (bytevector->base32-string
  638. (sha1 (string->utf8 fs)))
  639. 4)))
  640. (define (mapping->file-system mapping)
  641. "Return a 9p file system that realizes MAPPING."
  642. (match mapping
  643. (($ <file-system-mapping> source target writable?)
  644. (file-system
  645. (mount-point target)
  646. (device (file-system->mount-tag source))
  647. (type "9p")
  648. (flags (if writable? '() '(read-only)))
  649. (options "trans=virtio,cache=loose")
  650. (check? #f)
  651. (create-mount-point? #t)))))
  652. (define* (virtualized-operating-system os mappings #:optional (full-boot? #f))
  653. "Return an operating system based on OS suitable for use in a virtualized
  654. environment with the store shared with the host. MAPPINGS is a list of
  655. <file-system-mapping> to realize in the virtualized OS."
  656. (define user-file-systems
  657. ;; Remove file systems that conflict with those added below, or that are
  658. ;; normally bound to real devices.
  659. (remove (lambda (fs)
  660. (let ((target (file-system-mount-point fs))
  661. (source (file-system-device fs)))
  662. (or (string=? target (%store-prefix))
  663. (string=? target "/")
  664. (and (string? source)
  665. (string-prefix? "/dev/" source))
  666. ;; Labels and UUIDs are necessarily invalid in the VM.
  667. (and (file-system-mount? fs)
  668. (or (file-system-label? source)
  669. (uuid? source))))))
  670. (operating-system-file-systems os)))
  671. (define virtual-file-systems
  672. (cons (file-system
  673. (mount-point "/")
  674. (device "/dev/vda1")
  675. (type "ext4"))
  676. (append (map mapping->file-system mappings)
  677. user-file-systems)))
  678. (operating-system (inherit os)
  679. ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware),
  680. ;; force the traditional i386/BIOS method.
  681. ;; See <https://bugs.gnu.org/28768>.
  682. (bootloader (bootloader-configuration
  683. (bootloader grub-bootloader)
  684. (target "/dev/vda")))
  685. (initrd (lambda (file-systems . rest)
  686. (apply (operating-system-initrd os)
  687. file-systems
  688. #:volatile-root? #t
  689. rest)))
  690. ;; Disable swap.
  691. (swap-devices '())
  692. ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
  693. ;; since that would lead the bootloader config to look for the kernel and
  694. ;; initrd in it.
  695. (file-systems (if full-boot?
  696. virtual-file-systems
  697. (cons
  698. (file-system
  699. (inherit (mapping->file-system %store-mapping))
  700. (needed-for-boot? #t))
  701. virtual-file-systems)))))
  702. (define* (system-qemu-image/shared-store
  703. os
  704. #:key
  705. full-boot?
  706. (disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
  707. "Return a derivation that builds a QEMU image of OS that shares its store
  708. with the host.
  709. When FULL-BOOT? is true, return an image that does a complete boot sequence,
  710. bootloaded included; thus, make a disk image that contains everything the
  711. bootloader refers to: OS kernel, initrd, bootloader data, etc."
  712. (define root-uuid
  713. ;; Use a fixed UUID to improve determinism.
  714. (operating-system-uuid os 'dce))
  715. (mlet* %store-monad ((os-drv (operating-system-derivation os))
  716. (bootcfg (operating-system-bootcfg os)))
  717. ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
  718. ;; BOOTCFG and all its dependencies, including the output of OS-DRV.
  719. ;; This is more than needed (we only need the kernel, initrd, GRUB for its
  720. ;; font, and the background image), but it's hard to filter that.
  721. (qemu-image #:os-drv os-drv
  722. #:bootcfg-drv bootcfg
  723. #:bootloader (bootloader-configuration-bootloader
  724. (operating-system-bootloader os))
  725. #:disk-image-size disk-image-size
  726. #:file-system-uuid root-uuid
  727. #:inputs (if full-boot?
  728. `(("bootcfg" ,bootcfg))
  729. '())
  730. ;; XXX: Passing #t here is too slow, so let it off by default.
  731. #:register-closures? #f
  732. #:copy-inputs? full-boot?)))
  733. (define* (common-qemu-options image shared-fs)
  734. "Return the a string-value gexp with the common QEMU options to boot IMAGE,
  735. with '-virtfs' options for the host file systems listed in SHARED-FS."
  736. (define (virtfs-option fs)
  737. #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s"
  738. #$fs #$(file-system->mount-tag fs)))
  739. #~(;; Only enable kvm if we see /dev/kvm exists.
  740. ;; This allows users without hardware virtualization to still use these
  741. ;; commands.
  742. #$@(if (file-exists? "/dev/kvm")
  743. '("-enable-kvm")
  744. '())
  745. "-no-reboot"
  746. "-net nic,model=virtio"
  747. "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
  748. "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
  749. #$@(map virtfs-option shared-fs)
  750. "-vga std"
  751. (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly"
  752. #$image)))
  753. (define* (system-qemu-image/shared-store-script os
  754. #:key
  755. (qemu qemu)
  756. (graphic? #t)
  757. (memory-size 256)
  758. (mappings '())
  759. full-boot?
  760. (disk-image-size
  761. (* (if full-boot? 500 70)
  762. (expt 2 20)))
  763. (options '()))
  764. "Return a derivation that builds a script to run a virtual machine image of
  765. OS that shares its store with the host. The virtual machine runs with
  766. MEMORY-SIZE MiB of memory.
  767. MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
  768. systems into the guest.
  769. When FULL-BOOT? is true, the returned script runs everything starting from the
  770. bootloader; otherwise it directly starts the operating system kernel. The
  771. DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
  772. it is mostly useful when FULL-BOOT? is true."
  773. (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?))
  774. (os-drv (operating-system-derivation os))
  775. (image (system-qemu-image/shared-store
  776. os
  777. #:full-boot? full-boot?
  778. #:disk-image-size disk-image-size)))
  779. (define kernel-arguments
  780. #~(list #$@(if graphic? #~() #~("console=ttyS0"))
  781. #+@(operating-system-kernel-arguments os os-drv "/dev/vda1")))
  782. (define qemu-exec
  783. #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
  784. #$@(if full-boot?
  785. #~()
  786. #~("-kernel" #$(operating-system-kernel-file os)
  787. "-initrd" #$(file-append os-drv "/initrd")
  788. (format #f "-append ~s"
  789. (string-join #$kernel-arguments " "))))
  790. #$@(common-qemu-options image
  791. (map file-system-mapping-source
  792. (cons %store-mapping mappings)))
  793. "-m " (number->string #$memory-size)
  794. #$@options))
  795. (define builder
  796. #~(call-with-output-file #$output
  797. (lambda (port)
  798. (format port "#!~a~% exec ~a \"$@\"~%"
  799. #$(file-append bash "/bin/sh")
  800. (string-join #$qemu-exec " "))
  801. (chmod port #o555))))
  802. (gexp->derivation "run-vm.sh" builder)))
  803. ;;;
  804. ;;; High-level abstraction.
  805. ;;;
  806. (define-record-type* <virtual-machine> %virtual-machine
  807. make-virtual-machine
  808. virtual-machine?
  809. (operating-system virtual-machine-operating-system) ;<operating-system>
  810. (qemu virtual-machine-qemu ;<package>
  811. (default qemu))
  812. (graphic? virtual-machine-graphic? ;Boolean
  813. (default #f))
  814. (memory-size virtual-machine-memory-size ;integer (MiB)
  815. (default 256))
  816. (disk-image-size virtual-machine-disk-image-size ;integer (bytes)
  817. (default 'guess))
  818. (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
  819. (default '())))
  820. (define-syntax virtual-machine
  821. (syntax-rules ()
  822. "Declare a virtual machine running the specified OS, with the given
  823. options."
  824. ((_ os) ;shortcut
  825. (%virtual-machine (operating-system os)))
  826. ((_ fields ...)
  827. (%virtual-machine fields ...))))
  828. (define (port-forwardings->qemu-options forwardings)
  829. "Return the QEMU option for the given port FORWARDINGS as a string, where
  830. FORWARDINGS is a list of host-port/guest-port pairs."
  831. (string-join
  832. (map (match-lambda
  833. ((host-port . guest-port)
  834. (string-append "hostfwd=tcp::"
  835. (number->string host-port)
  836. "-:" (number->string guest-port))))
  837. forwardings)
  838. ","))
  839. (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
  840. system target)
  841. ;; XXX: SYSTEM and TARGET are ignored.
  842. (match vm
  843. (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ())
  844. (system-qemu-image/shared-store-script os
  845. #:qemu qemu
  846. #:graphic? graphic?
  847. #:memory-size memory-size
  848. #:disk-image-size
  849. disk-image-size))
  850. (($ <virtual-machine> os qemu graphic? memory-size disk-image-size
  851. forwardings)
  852. (let ((options
  853. `("-net" ,(string-append
  854. "user,"
  855. (port-forwardings->qemu-options forwardings)))))
  856. (system-qemu-image/shared-store-script os
  857. #:qemu qemu
  858. #:graphic? graphic?
  859. #:memory-size memory-size
  860. #:disk-image-size
  861. disk-image-size
  862. #:options options)))))
  863. ;;; vm.scm ends here