;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
+;;; Copyright © 2016, 2017 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.
;;;
(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 system uuid)
#: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)
partition-size
partition-file-system
partition-label
- partition-bootable?
+ partition-flags
partition-initializer
+ estimated-partition-size
root-partition-initializer
initialize-partition-table
- initialize-hard-disk))
+ initialize-hard-disk
+ make-iso9660-image))
;;; Commentary:
;;;
(define* (qemu-command #:optional (system %host-type))
"Return the default name of the QEMU command for SYSTEM."
- (let ((cpu (substring %host-type 0
- (string-index %host-type #\-))))
+ (let ((cpu (substring system 0
+ (string-index system #\-))))
(string-append "qemu-system-"
(if (string-match "^i[3456]86$" cpu)
"i386"
output
(qemu (qemu-command)) (memory-size 512)
linux initrd
- make-disk-image? (disk-image-size 100)
+ make-disk-image?
+ single-file-output?
+ target-arm32?
+ (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.
+the result to OUTPUT. If SINGLE-FILE-OUTPUT? is true, copy a single file from
+/xchg to OUTPUT. Otherwise, copy the contents of /xchg to a new directory
+OUTPUT.
When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
-DISK-IMAGE-SIZE MiB resulting from the execution of BUILDER, which may access
-it via /dev/hda.
+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'."
- (define image-file
- (string-append "image." disk-image-format))
+
+ (define arch-specific-flags
+ `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid
+ ;; hardware limits imposed by other machines.
+ ,@(if target-arm32? '("-M" "virt") '())
+
+ ;; Only enable kvm if we see /dev/kvm exists. This allows users without
+ ;; hardware virtualization to still use these commands. KVM support is
+ ;; still buggy on some ARM32 boards. Do not use it even if available.
+ ,@(if (and (file-exists? "/dev/kvm")
+ (not target-arm32?))
+ '("-enable-kvm")
+ '())
+ "-append"
+ ;; The serial port name differs between emulated architectures/machines.
+ ,@(if target-arm32?
+ `(,(string-append "console=ttyAMA0 --load=" builder))
+ `(,(string-append "console=ttyS0 --load=" builder)))
+ ;; NIC is not supported on ARM "virt" machine, so use a user mode
+ ;; network stack instead.
+ ,@(if target-arm32?
+ '("-device" "virtio-net-pci,netdev=mynet"
+ "-netdev" "user,id=mynet")
+ '("-net" "nic,model=virtio"))))
(when make-disk-image?
- (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
- image-file
- (number->string disk-image-size)))
- (error "qemu-img failed")))
+ (format #t "creating ~a image of ~,2f MiB...~%"
+ disk-image-format (/ disk-image-size (expt 2 20)))
+ (force-output)
+ (invoke "qemu-img" "create" "-f" disk-image-format output
+ (number->string disk-image-size)))
(mkdir "xchg")
graph-files))
(_ #f))
- (unless (zero?
- (apply system* qemu "-enable-kvm" "-nographic" "-no-reboot"
- "-m" (number->string memory-size)
- "-net" "nic,model=virtio"
- "-virtfs"
- (string-append "local,id=store_dev,path="
- (%store-directory)
- ",security_model=none,mount_tag=store")
- "-virtfs"
- (string-append "local,id=xchg_dev,path=xchg"
- ",security_model=none,mount_tag=xchg")
- "-kernel" linux
- "-initrd" initrd
- "-append" (string-append "console=ttyS0 --load="
- builder)
- (if make-disk-image?
- `("-drive" ,(string-append "file=" image-file
- ",if=virtio"))
- '())))
- (error "qemu failed" qemu))
-
- (if make-disk-image?
- (copy-file image-file output)
- (begin
- (mkdir output)
- (copy-recursively "xchg" output))))
+ (apply invoke qemu "-nographic" "-no-reboot"
+ "-m" (number->string memory-size)
+ "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
+ "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
+ "-virtfs"
+ (string-append "local,id=store_dev,path="
+ (%store-directory)
+ ",security_model=none,mount_tag=store")
+ "-virtfs"
+ (string-append "local,id=xchg_dev,path=xchg"
+ ",security_model=none,mount_tag=xchg")
+ "-kernel" linux
+ "-initrd" initrd
+ (append
+ (if make-disk-image?
+ `("-device" "virtio-blk,drive=myhd"
+ "-drive" ,(string-append "if=none,file=" output
+ ",format=" disk-image-format
+ ",id=myhd"))
+ '())
+ arch-specific-flags))
+
+ ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
+ (unless make-disk-image?
+ (if single-file-output?
+ (let ((graph? (lambda (name stat)
+ (member (basename name) references-graphs))))
+ (match (find-files "xchg" (negate graph?))
+ ((result)
+ (copy-file result output))
+ (x
+ (error "did not find a single result file" x))))
+ (begin
+ (mkdir output)
+ (copy-recursively "xchg" output)))))
\f
;;;
(size partition-size)
(file-system partition-file-system (default "ext4"))
(label partition-label (default #f))
- (bootable? partition-bootable? (default #f))
+ (uuid partition-uuid (default #f))
+ (flags partition-flags (default '()))
(initializer partition-initializer (default (const #t))))
-(define (fold2 proc seed1 seed2 lst) ;TODO: factorize
- "Like `fold', but with a single list and two seeds."
- (let loop ((result1 seed1)
- (result2 seed2)
- (lst lst))
- (if (null? lst)
- (values result1 result2)
- (call-with-values
- (lambda () (proc (car lst) result1 result2))
- (lambda (result1 result2)
- (loop result1 result2 (cdr lst)))))))
+(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
#:key
(cons* "mkpart" "primary" "ext2"
(format #f "~aB" offset)
(format #f "~aB" (+ offset (partition-size part)))
- (if (partition-bootable? part)
- `("set" ,(number->string index) "boot" "on")
- '())))
+ (append-map (lambda (flag)
+ (list "set" (number->string index)
+ (symbol->string flag) "on"))
+ (partition-flags part))))
(define (options partitions offset)
(let loop ((partitions partitions)
(cons (partition-options head offset index)
result))))))
- (format #t "creating partition table with ~a partitions...\n"
- (length partitions))
- (unless (zero? (apply system* "parted" "--script"
- device "mklabel" label-type
- (options partitions offset)))
- (error "failed to create partition table"))
+ (format #t "creating partition table with ~a partitions (~a)...\n"
+ (length partitions)
+ (string-join (map (compose (cut string-append <> " MiB")
+ number->string
+ (lambda (size)
+ (round (/ size (expt 2. 20))))
+ partition-size)
+ partitions)
+ ", "))
+ (apply invoke "parted" "--script"
+ device "mklabel" label-type
+ (options partitions offset))
;; Set the 'device' field of each partition.
(reverse
(define MS_BIND 4096) ; <sys/mounts.h> again!
+(define* (create-ext-file-system partition type
+ #:key label uuid)
+ "Create an ext-family file system of TYPE on PARTITION. If LABEL is true,
+use that as the volume name. If UUID is true, use it as the partition UUID."
+ (format #t "creating ~a partition...\n" type)
+ (apply invoke (string-append "mkfs." type)
+ "-F" partition
+ `(,@(if label
+ `("-L" ,label)
+ '())
+ ,@(if uuid
+ `("-U" ,(uuid->string uuid))
+ '()))))
+
+(define* (create-fat-file-system partition
+ #:key label uuid)
+ "Create a FAT file system on PARTITION. The number of File Allocation Tables
+will be determined based on file system size. If LABEL is true, use that as the
+volume name."
+ ;; FIXME: UUID is ignored!
+ (format #t "creating FAT partition...\n")
+ (apply invoke "mkfs.fat" partition
+ (if label `("-n" ,label) '())))
+
(define* (format-partition partition type
- #:key label)
+ #:key label uuid)
"Create a file system 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")))
+ (cond ((string-prefix? "ext" type)
+ (create-ext-file-system partition type #:label label #:uuid uuid))
+ ((or (string-prefix? "fat" type) (string= "vfat" type))
+ (create-fat-file-system partition #:label label #:uuid uuid))
+ (else (error "Unsupported file system."))))
(define (initialize-partition partition)
"Format PARTITION, a <partition> object with a non-#f 'device' field, mount
(let ((target "/fs"))
(format-partition (partition-device partition)
(partition-file-system partition)
- #:label (partition-label partition))
+ #:label (partition-label partition)
+ #:uuid (partition-uuid partition))
(mkdir-p target)
(mount (partition-device partition) target
(partition-file-system partition))
(unless register-closures?
(reset-timestamps target))))
-(define (register-grub.cfg-root target grub.cfg)
- "On file system TARGET, register GRUB.CFG as a GC root."
+(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 grub.cfg (string-append directory "/grub.cfg"))))
+ (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 "3.5.1.1 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)
+ (invoke 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))))
+
+(define* (make-iso9660-image grub config-file os-drv target
+ #:key (volume-id "GuixSD_image") (volume-uuid #f)
+ register-closures? (closures '()))
+ "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"))
+ (target-store (string-append "/tmp/root" (%store-directory))))
+ (populate-root-file-system os-drv "/tmp/root")
+
+ (mount (%store-directory) target-store "" MS_BIND)
+
+ (when register-closures?
+ (display "registering closures...\n")
+ (for-each (lambda (closure)
+ (register-closure
+ "/tmp/root"
+ (string-append "/xchg/" closure)
+ ;; XXX: Using deduplication causes cross device link errors.
+ #:deduplicate? #f))
+ closures))
+
+ (apply invoke
+ `(,grub-mkrescue "-o" ,target
+ ,(string-append "boot/grub/grub.cfg=" config-file)
+ ,(string-append "gnu/store=" os-drv "/..")
+ "etc=/tmp/root/etc"
+ "var=/tmp/root/var"
+ "run=/tmp/root/run"
+ ;; /mnt is used as part of the installation
+ ;; process, as the mount point for the target
+ ;; file system, so create it.
+ "mnt=/tmp/root/mnt"
+ "--"
+ "-volid" ,(string-upcase volume-id)
+ ,@(if volume-uuid
+ `("-volume_date" "uuid"
+ ,(string-filter (lambda (value)
+ (not (char=? #\- value)))
+ (iso9660-uuid->string
+ volume-uuid)))
+ `())))))
(define* (initialize-hard-disk device
#:key
- grub.cfg
+ bootloader-package
+ bootcfg
+ bootcfg-location
+ bootloader-installer
+ (grub-efi #f)
(partitions '()))
"Initialize DEVICE as a disk containing all the <partition> objects listed
-in PARTITIONS, and using GRUB.CFG as its bootloader configuration file.
+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))
(display "mounting root partition...\n")
(mkdir-p target)
(mount (partition-device root) target (partition-file-system root))
- (install-grub grub.cfg device target)
-
- ;; Register GRUB.CFG as a GC root.
- (register-grub.cfg-root target grub.cfg)
+ (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)))
HCoop / jackhill / guix / guix.git / blobdiff