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.
 
 
 
 
 
 

521 lines
21 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 build vm)
  24. #:use-module (guix build utils)
  25. #:use-module (guix build store-copy)
  26. #:use-module (guix build syscalls)
  27. #:use-module ((guix store database) #:select (reset-timestamps))
  28. #:use-module (gnu build linux-boot)
  29. #:use-module (gnu build install)
  30. #:use-module (gnu system uuid)
  31. #:use-module (guix records)
  32. #:use-module ((guix combinators) #:select (fold2))
  33. #:use-module (ice-9 format)
  34. #:use-module (ice-9 match)
  35. #:use-module (ice-9 regex)
  36. #:use-module (srfi srfi-1)
  37. #:use-module (srfi srfi-9)
  38. #:use-module (srfi srfi-26)
  39. #:export (qemu-command
  40. load-in-linux-vm
  41. format-partition
  42. partition
  43. partition?
  44. partition-device
  45. partition-size
  46. partition-file-system
  47. partition-label
  48. partition-flags
  49. partition-initializer
  50. estimated-partition-size
  51. root-partition-initializer
  52. initialize-partition-table
  53. initialize-hard-disk
  54. make-iso9660-image))
  55. ;;; Commentary:
  56. ;;;
  57. ;;; This module provides supporting code to run virtual machines and build
  58. ;;; virtual machine images using QEMU.
  59. ;;;
  60. ;;; Code:
  61. (define* (qemu-command #:optional (system %host-type))
  62. "Return the default name of the QEMU command for SYSTEM."
  63. (let ((cpu (substring system 0
  64. (string-index system #\-))))
  65. (string-append "qemu-system-"
  66. (if (string-match "^i[3456]86$" cpu)
  67. "i386"
  68. cpu))))
  69. (define* (load-in-linux-vm builder
  70. #:key
  71. output
  72. (qemu (qemu-command)) (memory-size 512)
  73. linux initrd
  74. make-disk-image?
  75. single-file-output?
  76. target-arm32?
  77. (disk-image-size (* 100 (expt 2 20)))
  78. (disk-image-format "qcow2")
  79. (references-graphs '()))
  80. "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
  81. the result to OUTPUT. If SINGLE-FILE-OUTPUT? is true, copy a single file from
  82. /xchg to OUTPUT. Otherwise, copy the contents of /xchg to a new directory
  83. OUTPUT.
  84. When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
  85. DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
  86. access it via /dev/hda.
  87. REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
  88. the #:references-graphs parameter of 'derivation'."
  89. (define arch-specific-flags
  90. `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid
  91. ;; hardware limits imposed by other machines.
  92. ,@(if target-arm32? '("-M" "virt") '())
  93. ;; Only enable kvm if we see /dev/kvm exists. This allows users without
  94. ;; hardware virtualization to still use these commands. KVM support is
  95. ;; still buggy on some ARM32 boards. Do not use it even if available.
  96. ,@(if (and (file-exists? "/dev/kvm")
  97. (not target-arm32?))
  98. '("-enable-kvm")
  99. '())
  100. ;; Pass "panic=1" so that the guest dies upon error.
  101. "-append"
  102. ,(string-append "panic=1 --load=" builder
  103. ;; The serial port name differs between emulated
  104. ;; architectures/machines.
  105. " console="
  106. (if target-arm32? "ttyAMA0" "ttyS0"))
  107. ;; NIC is not supported on ARM "virt" machine, so use a user mode
  108. ;; network stack instead.
  109. ,@(if target-arm32?
  110. '("-device" "virtio-net-pci,netdev=mynet"
  111. "-netdev" "user,id=mynet")
  112. '("-net" "nic,model=virtio"))))
  113. (when make-disk-image?
  114. (format #t "creating ~a image of ~,2f MiB...~%"
  115. disk-image-format (/ disk-image-size (expt 2 20)))
  116. (force-output)
  117. (invoke "qemu-img" "create" "-f" disk-image-format output
  118. (number->string disk-image-size)))
  119. (mkdir "xchg")
  120. (mkdir "tmp")
  121. (match references-graphs
  122. ((graph-files ...)
  123. ;; Copy the reference-graph files under xchg/ so EXP can access it.
  124. (map (lambda (file)
  125. (copy-file file (string-append "xchg/" file)))
  126. graph-files))
  127. (_ #f))
  128. (apply invoke qemu "-nographic" "-no-reboot"
  129. "-m" (number->string memory-size)
  130. "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
  131. "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
  132. "-virtfs"
  133. (string-append "local,id=store_dev,path="
  134. (%store-directory)
  135. ",security_model=none,mount_tag=store")
  136. "-virtfs"
  137. (string-append "local,id=xchg_dev,path=xchg"
  138. ",security_model=none,mount_tag=xchg")
  139. "-virtfs"
  140. ;; Some programs require more space in /tmp than is normally
  141. ;; available in the guest. Accommodate such programs by sharing a
  142. ;; temporary directory.
  143. (string-append "local,id=tmp_dev,path=tmp"
  144. ",security_model=none,mount_tag=tmp")
  145. "-kernel" linux
  146. "-initrd" initrd
  147. (append
  148. (if make-disk-image?
  149. `("-device" "virtio-blk,drive=myhd"
  150. "-drive" ,(string-append "if=none,file=" output
  151. ",format=" disk-image-format
  152. ",id=myhd"))
  153. '())
  154. arch-specific-flags))
  155. ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
  156. (unless make-disk-image?
  157. (if single-file-output?
  158. (let ((graph? (lambda (name stat)
  159. (member (basename name) references-graphs))))
  160. (match (find-files "xchg" (negate graph?))
  161. ((result)
  162. (copy-file result output))
  163. (x
  164. (error "did not find a single result file" x))))
  165. (begin
  166. (mkdir output)
  167. (copy-recursively "xchg" output)))))
  168. ;;;
  169. ;;; Partitions.
  170. ;;;
  171. (define-record-type* <partition> partition make-partition
  172. partition?
  173. (device partition-device (default #f))
  174. (size partition-size)
  175. (file-system partition-file-system (default "ext4"))
  176. (label partition-label (default #f))
  177. (uuid partition-uuid (default #f))
  178. (flags partition-flags (default '()))
  179. (initializer partition-initializer (default (const #t))))
  180. (define (estimated-partition-size graphs)
  181. "Return the estimated size of a partition that can store the store items
  182. given by GRAPHS, a list of file names produced by #:references-graphs."
  183. ;; Simply add a 25% overhead.
  184. (round (* 1.25 (closure-size graphs))))
  185. (define* (initialize-partition-table device partitions
  186. #:key
  187. (label-type "msdos")
  188. (offset (expt 2 20)))
  189. "Create on DEVICE a partition table of type LABEL-TYPE, containing the given
  190. PARTITIONS (a list of <partition> objects), starting at OFFSET bytes. On
  191. success, return PARTITIONS with their 'device' field changed to reflect their
  192. actual /dev name based on DEVICE."
  193. (define (partition-options part offset index)
  194. (cons* "mkpart" "primary" "ext2"
  195. (format #f "~aB" offset)
  196. (format #f "~aB" (+ offset (partition-size part)))
  197. (append-map (lambda (flag)
  198. (list "set" (number->string index)
  199. (symbol->string flag) "on"))
  200. (partition-flags part))))
  201. (define (options partitions offset)
  202. (let loop ((partitions partitions)
  203. (offset offset)
  204. (index 1)
  205. (result '()))
  206. (match partitions
  207. (()
  208. (concatenate (reverse result)))
  209. ((head tail ...)
  210. (loop tail
  211. ;; Leave one sector (512B) between partitions to placate
  212. ;; Parted.
  213. (+ offset 512 (partition-size head))
  214. (+ 1 index)
  215. (cons (partition-options head offset index)
  216. result))))))
  217. (format #t "creating partition table with ~a partitions (~a)...\n"
  218. (length partitions)
  219. (string-join (map (compose (cut string-append <> " MiB")
  220. number->string
  221. (lambda (size)
  222. (round (/ size (expt 2. 20))))
  223. partition-size)
  224. partitions)
  225. ", "))
  226. (apply invoke "parted" "--script"
  227. device "mklabel" label-type
  228. (options partitions offset))
  229. ;; Set the 'device' field of each partition.
  230. (reverse
  231. (fold2 (lambda (part result index)
  232. (values (cons (partition
  233. (inherit part)
  234. (device (string-append device
  235. (number->string index))))
  236. result)
  237. (+ 1 index)))
  238. '()
  239. 1
  240. partitions)))
  241. (define MS_BIND 4096) ; <sys/mounts.h> again!
  242. (define* (create-ext-file-system partition type
  243. #:key label uuid)
  244. "Create an ext-family file system of TYPE on PARTITION. If LABEL is true,
  245. use that as the volume name. If UUID is true, use it as the partition UUID."
  246. (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n"
  247. type label (and uuid (uuid->string uuid)))
  248. (apply invoke (string-append "mkfs." type)
  249. "-F" partition
  250. `(,@(if label
  251. `("-L" ,label)
  252. '())
  253. ,@(if uuid
  254. `("-U" ,(uuid->string uuid))
  255. '()))))
  256. (define* (create-fat-file-system partition
  257. #:key label uuid)
  258. "Create a FAT file system on PARTITION. The number of File Allocation Tables
  259. will be determined based on file system size. If LABEL is true, use that as the
  260. volume name."
  261. ;; FIXME: UUID is ignored!
  262. (format #t "creating FAT partition...\n")
  263. (apply invoke "mkfs.fat" partition
  264. (if label `("-n" ,label) '())))
  265. (define* (format-partition partition type
  266. #:key label uuid)
  267. "Create a file system TYPE on PARTITION. If LABEL is true, use that as the
  268. volume name."
  269. (cond ((string-prefix? "ext" type)
  270. (create-ext-file-system partition type #:label label #:uuid uuid))
  271. ((or (string-prefix? "fat" type) (string= "vfat" type))
  272. (create-fat-file-system partition #:label label #:uuid uuid))
  273. (else (error "Unsupported file system."))))
  274. (define (initialize-partition partition)
  275. "Format PARTITION, a <partition> object with a non-#f 'device' field, mount
  276. it, run its initializer, and unmount it."
  277. (let ((target "/fs"))
  278. (format-partition (partition-device partition)
  279. (partition-file-system partition)
  280. #:label (partition-label partition)
  281. #:uuid (partition-uuid partition))
  282. (mkdir-p target)
  283. (mount (partition-device partition) target
  284. (partition-file-system partition))
  285. ((partition-initializer partition) target)
  286. (umount target)
  287. partition))
  288. (define* (root-partition-initializer #:key (closures '())
  289. copy-closures?
  290. (register-closures? #t)
  291. system-directory
  292. (deduplicate? #t))
  293. "Return a procedure to initialize a root partition.
  294. If REGISTER-CLOSURES? is true, register all of CLOSURES in the partition's
  295. store. If DEDUPLICATE? is true, then also deduplicate files common to
  296. CLOSURES and the rest of the store when registering the closures. If
  297. COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
  298. SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
  299. (lambda (target)
  300. (define target-store
  301. (string-append target (%store-directory)))
  302. (when copy-closures?
  303. ;; Populate the store.
  304. (populate-store (map (cut string-append "/xchg/" <>) closures)
  305. target))
  306. ;; Populate /dev.
  307. (make-essential-device-nodes #:root target)
  308. ;; Optionally, register the inputs in the image's store.
  309. (when register-closures?
  310. (unless copy-closures?
  311. ;; XXX: 'register-closure' wants to palpate the things it registers, so
  312. ;; bind-mount the store on the target.
  313. (mkdir-p target-store)
  314. (mount (%store-directory) target-store "" MS_BIND))
  315. (display "registering closures...\n")
  316. (for-each (lambda (closure)
  317. (register-closure target
  318. (string-append "/xchg/" closure)
  319. #:reset-timestamps? copy-closures?
  320. #:deduplicate? deduplicate?))
  321. closures)
  322. (unless copy-closures?
  323. (umount target-store)))
  324. ;; Add the non-store directories and files.
  325. (display "populating...\n")
  326. (populate-root-file-system system-directory target)
  327. ;; 'register-closure' resets timestamps and everything, so no need to do it
  328. ;; once more in that case.
  329. (unless register-closures?
  330. (reset-timestamps target))))
  331. (define (register-bootcfg-root target bootcfg)
  332. "On file system TARGET, register BOOTCFG as a GC root."
  333. (let ((directory (string-append target "/var/guix/gcroots")))
  334. (mkdir-p directory)
  335. (symlink bootcfg (string-append directory "/bootcfg"))))
  336. (define (install-efi grub esp config-file)
  337. "Write a self-contained GRUB EFI loader to the mounted ESP using CONFIG-FILE."
  338. (let* ((system %host-type)
  339. ;; Hard code the output location to a well-known path recognized by
  340. ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
  341. ;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
  342. (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
  343. (efi-directory (string-append esp "/EFI/BOOT"))
  344. ;; Map grub target names to boot file names.
  345. (efi-targets (cond ((string-prefix? "x86_64" system)
  346. '("x86_64-efi" . "BOOTX64.EFI"))
  347. ((string-prefix? "i686" system)
  348. '("i386-efi" . "BOOTIA32.EFI"))
  349. ((string-prefix? "armhf" system)
  350. '("arm-efi" . "BOOTARM.EFI"))
  351. ((string-prefix? "aarch64" system)
  352. '("arm64-efi" . "BOOTAA64.EFI")))))
  353. ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
  354. (setenv "TMPDIR" esp)
  355. (mkdir-p efi-directory)
  356. (invoke grub-mkstandalone "-O" (car efi-targets)
  357. "-o" (string-append efi-directory "/"
  358. (cdr efi-targets))
  359. ;; Graft the configuration file onto the image.
  360. (string-append "boot/grub/grub.cfg=" config-file))))
  361. (define* (make-iso9660-image grub config-file os-drv target
  362. #:key (volume-id "GuixSD_image") (volume-uuid #f)
  363. register-closures? (closures '()))
  364. "Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
  365. GRUB configuration and OS-DRV as the stuff in it."
  366. (let ((grub-mkrescue (string-append grub "/bin/grub-mkrescue"))
  367. (target-store (string-append "/tmp/root" (%store-directory))))
  368. (populate-root-file-system os-drv "/tmp/root")
  369. (mount (%store-directory) target-store "" MS_BIND)
  370. (when register-closures?
  371. (display "registering closures...\n")
  372. (for-each (lambda (closure)
  373. (register-closure
  374. "/tmp/root"
  375. (string-append "/xchg/" closure)
  376. ;; XXX: Using deduplication causes cross device link errors.
  377. #:deduplicate? #f))
  378. closures))
  379. (apply invoke
  380. `(,grub-mkrescue "-o" ,target
  381. ,(string-append "boot/grub/grub.cfg=" config-file)
  382. ,(string-append "gnu/store=" os-drv "/..")
  383. "etc=/tmp/root/etc"
  384. "var=/tmp/root/var"
  385. "run=/tmp/root/run"
  386. ;; /mnt is used as part of the installation
  387. ;; process, as the mount point for the target
  388. ;; file system, so create it.
  389. "mnt=/tmp/root/mnt"
  390. "--"
  391. "-volid" ,(string-upcase volume-id)
  392. ,@(if volume-uuid
  393. `("-volume_date" "uuid"
  394. ,(string-filter (lambda (value)
  395. (not (char=? #\- value)))
  396. (iso9660-uuid->string
  397. volume-uuid)))
  398. `())))))
  399. (define* (initialize-hard-disk device
  400. #:key
  401. bootloader-package
  402. bootcfg
  403. bootcfg-location
  404. bootloader-installer
  405. (grub-efi #f)
  406. (partitions '()))
  407. "Initialize DEVICE as a disk containing all the <partition> objects listed
  408. in PARTITIONS, and using BOOTCFG as its bootloader configuration file.
  409. Each partition is initialized by calling its 'initializer' procedure,
  410. passing it a directory name where it is mounted."
  411. (define (partition-bootable? partition)
  412. "Return the first partition found with the boot flag set."
  413. (member 'boot (partition-flags partition)))
  414. (define (partition-esp? partition)
  415. "Return the first EFI System Partition."
  416. (member 'esp (partition-flags partition)))
  417. (let* ((partitions (initialize-partition-table device partitions))
  418. (root (find partition-bootable? partitions))
  419. (esp (find partition-esp? partitions))
  420. (target "/fs"))
  421. (unless root
  422. (error "no bootable partition specified" partitions))
  423. (for-each initialize-partition partitions)
  424. (display "mounting root partition...\n")
  425. (mkdir-p target)
  426. (mount (partition-device root) target (partition-file-system root))
  427. (install-boot-config bootcfg bootcfg-location target)
  428. (when bootloader-installer
  429. (display "installing bootloader...\n")
  430. (bootloader-installer bootloader-package device target))
  431. (when esp
  432. ;; Mount the ESP somewhere and install GRUB UEFI image.
  433. (let ((mount-point (string-append target "/boot/efi"))
  434. (grub-config (string-append target "/tmp/grub-standalone.cfg")))
  435. (display "mounting EFI system partition...\n")
  436. (mkdir-p mount-point)
  437. (mount (partition-device esp) mount-point
  438. (partition-file-system esp))
  439. ;; Create a tiny configuration file telling the embedded grub
  440. ;; where to load the real thing.
  441. ;; XXX This is quite fragile, and can prevent the image from booting
  442. ;; when there's more than one volume with this label present.
  443. ;; Reproducible almost-UUIDs could reduce the risk (not eliminate it).
  444. (call-with-output-file grub-config
  445. (lambda (port)
  446. (format port
  447. "insmod part_msdos~@
  448. search --set=root --label GuixSD_image~@
  449. configfile /boot/grub/grub.cfg~%")))
  450. (display "creating EFI firmware image...")
  451. (install-efi grub-efi mount-point grub-config)
  452. (display "done.\n")
  453. (delete-file grub-config)
  454. (umount mount-point)))
  455. ;; Register BOOTCFG as a GC root.
  456. (register-bootcfg-root target bootcfg)
  457. (umount target)))
  458. ;;; vm.scm ends here