Mirror of GNU Guix
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.

465 lines
19 KiB

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; This file is part of GNU Guix.
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; GNU General Public License for more details.
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build vm)
#:use-module (guix build utils)
#:use-module (guix build store-copy)
#:use-module (guix build syscalls)
#:use-module (gnu build linux-boot)
#:use-module (gnu build install)
#:use-module (gnu build file-systems)
#:use-module (guix records)
#:use-module ((guix combinators) #:select (fold2))
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:export (qemu-command
;;; Commentary:
;;; This module provides supporting code to run virtual machines and build
;;; virtual machine images using QEMU.
;;; Code:
(define* (qemu-command #:optional (system %host-type))
"Return the default name of the QEMU command for SYSTEM."
(let ((cpu (substring system 0
(string-index system #\-))))
(string-append "qemu-system-"
(if (string-match "^i[3456]86$" cpu)
(define* (load-in-linux-vm builder
(qemu (qemu-command)) (memory-size 512)
linux initrd
(disk-image-size (* 100 (expt 2 20)))
(disk-image-format "qcow2")
(references-graphs '()))
"Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
the result to OUTPUT.
When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
access it via /dev/hda.
REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
the #:references-graphs parameter of 'derivation'."
(when make-disk-image?
(format #t "creating ~a image of ~,2f MiB...~%"
disk-image-format (/ disk-image-size (expt 2 20)))
(unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
(number->string disk-image-size)))
(error "qemu-img failed")))
(mkdir "xchg")
(match references-graphs
((graph-files ...)
;; Copy the reference-graph files under xchg/ so EXP can access it.
(map (lambda (file)
(copy-file file (string-append "xchg/" file)))
(_ #f))
(unless (zero?
(apply system* qemu "-nographic" "-no-reboot"
"-m" (number->string memory-size)
"-net" "nic,model=virtio"
(string-append "local,id=store_dev,path="
(string-append "local,id=xchg_dev,path=xchg"
"-kernel" linux
"-initrd" initrd
"-append" (string-append "console=ttyS0 --load="
(if make-disk-image?
`("-drive" ,(string-append "file=" output
;; Only enable kvm if we see /dev/kvm exists.
;; This allows users without hardware virtualization to still
;; use these commands.
(if (file-exists? "/dev/kvm")
(error "qemu failed" qemu))
;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
(unless make-disk-image?
(mkdir output)
(copy-recursively "xchg" output)))
;;; Partitions.
(define-record-type* <partition> partition make-partition
(device partition-device (default #f))
(size partition-size)
(file-system partition-file-system (default "ext4"))
(label partition-label (default #f))
(flags partition-flags (default '()))
(initializer partition-initializer (default (const #t))))
(define (estimated-partition-size graphs)
"Return the estimated size of a partition that can store the store items
given by GRAPHS, a list of file names produced by #:references-graphs."
;; Simply add a 25% overhead.
(round (* 1.25 (closure-size graphs))))
(define* (initialize-partition-table device partitions
(label-type "msdos")
(offset (expt 2 20)))
"Create on DEVICE a partition table of type LABEL-TYPE, containing the given
PARTITIONS (a list of <partition> objects), starting at OFFSET bytes. On
success, return PARTITIONS with their 'device' field changed to reflect their
actual /dev name based on DEVICE."
(define (partition-options part offset index)
(cons* "mkpart" "primary" "ext2"
(format #f "~aB" offset)
(format #f "~aB" (+ offset (partition-size part)))
(append-map (lambda (flag)
(list "set" (number->string index)
(symbol->string flag) "on"))
(partition-flags part))))
(define (options partitions offset)
(let loop ((partitions partitions)
(offset offset)
(index 1)
(result '()))
(match partitions
(concatenate (reverse result)))
((head tail ...)
(loop tail
;; Leave one sector (512B) between partitions to placate
;; Parted.
(+ offset 512 (partition-size head))
(+ 1 index)
(cons (partition-options head offset index)
(format #t "creating partition table with ~a partitions (~a)...\n"
(length partitions)
(string-join (map (compose (cut string-append <> " MiB")
(lambda (size)
(round (/ size (expt 2. 20))))
", "))
(unless (zero? (apply system* "parted" "--script"
device "mklabel" label-type
(options partitions offset)))
(error "failed to create partition table"))
;; Set the 'device' field of each partition.
(fold2 (lambda (part result index)
(values (cons (partition
(inherit part)
(device (string-append device
(number->string index))))
(+ 1 index)))
(define MS_BIND 4096) ; <sys/mounts.h> again!
(define* (create-ext-file-system partition type
#:key label)
"Create an ext-family filesystem of TYPE on PARTITION. If LABEL is true,
use that as the volume name."
(format #t "creating ~a partition...\n" type)
(unless (zero? (apply system* (string-append "mkfs." type)
"-F" partition
(if label
`("-L" ,label)
(error "failed to create partition")))
(define* (create-fat-file-system partition
#:key label)
"Create a FAT filesystem on PARTITION. The number of File Allocation Tables
will be determined based on filesystem size. If LABEL is true, use that as the
volume name."
(format #t "creating FAT partition...\n")
(unless (zero? (apply system* "mkfs.fat" partition
(if label
`("-n" ,label)
(error "failed to create FAT partition")))
(define* (format-partition partition type
#:key label)
"Create a file system TYPE on PARTITION. If LABEL is true, use that as the
volume name."
(cond ((string-prefix? "ext" type)
(create-ext-file-system partition type #:label label))
((or (string-prefix? "fat" type) (string= "vfat" type))
(create-fat-file-system partition #:label label))
(else (error "Unsupported file system."))))
(define (initialize-partition partition)
"Format PARTITION, a <partition> object with a non-#f 'device' field, mount
it, run its initializer, and unmount it."
(let ((target "/fs"))
(format-partition (partition-device partition)
(partition-file-system partition)
#:label (partition-label partition))
(mkdir-p target)
(mount (partition-device partition) target
(partition-file-system partition))
((partition-initializer partition) target)
(umount target)
(define* (root-partition-initializer #:key (closures '())
(register-closures? #t)
"Return a procedure to initialize a root partition.
If REGISTER-CLOSURES? is true, register all of CLOSURES is the partition's
store. If COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
(lambda (target)
(define target-store
(string-append target (%store-directory)))
(when copy-closures?
;; Populate the store.
(populate-store (map (cut string-append "/xchg/" <>) closures)
;; Populate /dev.
(make-essential-device-nodes #:root target)
;; Optionally, register the inputs in the image's store.
(when register-closures?
(unless copy-closures?
;; XXX: 'guix-register' wants to palpate the things it registers, so
;; bind-mount the store on the target.
(mkdir-p target-store)
(mount (%store-directory) target-store "" MS_BIND))
(display "registering closures...\n")
(for-each (lambda (closure)
(register-closure target
(string-append "/xchg/" closure)))
(unless copy-closures?
(umount target-store)))
;; Add the non-store directories and files.
(display "populating...\n")
(populate-root-file-system system-directory target)
;; 'guix-register' resets timestamps and everything, so no need to do it
;; once more in that case.
(unless register-closures?
(reset-timestamps target))))
(define (register-bootcfg-root target bootcfg)
"On file system TARGET, register BOOTCFG as a GC root."
(let ((directory (string-append target "/var/guix/gcroots")))
(mkdir-p directory)
(symlink bootcfg (string-append directory "/bootcfg"))))
(define (install-efi grub esp config-file)
"Write a self-contained GRUB EFI loader to the mounted ESP using CONFIG-FILE."
(let* ((system %host-type)
;; Hard code the output location to a well-known path recognized by
;; compliant firmware. See " Removable Media Boot Behaviour":
;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
(grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
(efi-directory (string-append esp "/EFI/BOOT"))
;; Map grub target names to boot file names.
(efi-targets (cond ((string-prefix? "x86_64" system)
'("x86_64-efi" . "BOOTX64.EFI"))
((string-prefix? "i686" system)
'("i386-efi" . "BOOTIA32.EFI"))
((string-prefix? "armhf" system)
'("arm-efi" . "BOOTARM.EFI"))
((string-prefix? "aarch64" system)
'("arm64-efi" . "BOOTAA64.EFI")))))
;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
(setenv "TMPDIR" esp)
(mkdir-p efi-directory)
(unless (zero? (system* grub-mkstandalone "-O" (car efi-targets)
"-o" (string-append efi-directory "/"
(cdr efi-targets))
;; Graft the configuration file onto the image.
(string-append "boot/grub/grub.cfg=" config-file)))
(error "failed to create GRUB EFI image"))))
(define* (make-iso9660-image grub config-file os-drv target
#:key (volume-id "GuixSD_image") (volume-uuid #f))
"Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
Grub configuration and OS-DRV as the stuff in it."
(let ((grub-mkrescue (string-append grub "/bin/grub-mkrescue")))
(mkdir-p "/tmp/root/var/run")
(mkdir-p "/tmp/root/run")
(unless (zero? (apply system*
`(,grub-mkrescue "-o" ,target
,(string-append "boot/grub/grub.cfg=" config-file)
,(string-append "gnu/store=" os-drv "/..")
;; Store two copies of the headers.
;; The resulting ISO-9660 image has a DOS MBR and
;; one protective partition (with type 0xCD).
;; Because GuixSD only uses actual partitions
;; rather than what /proc/partitions returns, work
;; around it by storing the primary volume
;; descriptor twice, once where it should be and
;; once in the partition.
;; Allegedly, otherwise, many other GNU tools
;; (automounters etc) would also be confused by
;; the extra partition so it makes sense to
;; store two copies in any case.
"-boot_image" "any" "partition_offset=16"
"-volid" ,(string-upcase volume-id)
,@(if volume-uuid
`("-volume_date" "uuid"
,(string-filter (lambda (value)
(not (char=? #\- value)))
(error "failed to create ISO9660 image"))))
(define* (initialize-hard-disk device
(grub-efi #f)
(partitions '()))
"Initialize DEVICE as a disk containing all the <partition> objects listed
in PARTITIONS, and using BOOTCFG as its bootloader configuration file.
Each partition is initialized by calling its 'initializer' procedure,
passing it a directory name where it is mounted."
(define (partition-bootable? partition)
"Return the first partition found with the boot flag set."
(member 'boot (partition-flags partition)))
(define (partition-esp? partition)
"Return the first EFI System Partition."
(member 'esp (partition-flags partition)))
(let* ((partitions (initialize-partition-table device partitions))
(root (find partition-bootable? partitions))
(esp (find partition-esp? partitions))
(target "/fs"))
(unless root
(error "no bootable partition specified" partitions))
(for-each initialize-partition partitions)
(display "mounting root partition...\n")
(mkdir-p target)
(mount (partition-device root) target (partition-file-system root))
(install-boot-config bootcfg bootcfg-location target)
(when bootloader-installer
(display "installing bootloader...\n")
(bootloader-installer bootloader-package device target))
(when esp
;; Mount the ESP somewhere and install GRUB UEFI image.
(let ((mount-point (string-append target "/boot/efi"))
(grub-config (string-append target "/tmp/grub-standalone.cfg")))
(display "mounting EFI system partition...\n")
(mkdir-p mount-point)
(mount (partition-device esp) mount-point
(partition-file-system esp))
;; Create a tiny configuration file telling the embedded grub
;; where to load the real thing.
;; XXX This is quite fragile, and can prevent the image from booting
;; when there's more than one volume with this label present.
;; Reproducible almost-UUIDs could reduce the risk (not eliminate it).
(call-with-output-file grub-config
(lambda (port)
(format port
"insmod part_msdos~@
search --set=root --label GuixSD_image~@
configfile /boot/grub/grub.cfg~%")))
(display "creating EFI firmware image...")
(install-efi grub-efi mount-point grub-config)
(display "done.\n")
(delete-file grub-config)
(umount mount-point)))
;; Register BOOTCFG as a GC root.
(register-bootcfg-root target bootcfg)
(umount target)))
;;; vm.scm ends here