;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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>
+;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix build utils)
#:use-module (guix build store-copy)
#:use-module (guix build syscalls)
+ #:use-module (guix store database)
+ #:use-module (gnu build bootloader)
#: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 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 popen)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:export (qemu-command
load-in-linux-vm
estimated-partition-size
root-partition-initializer
initialize-partition-table
- initialize-hard-disk
- make-iso9660-image))
+ initialize-hard-disk))
;;; Commentary:
;;;
(let ((cpu (substring system 0
(string-index system #\-))))
(string-append "qemu-system-"
- (if (string-match "^i[3456]86$" cpu)
- "i386"
- cpu))))
+ (cond
+ ((string-match "^i[3456]86$" cpu) "i386")
+ ((string-match "armhf" cpu) "arm")
+ (else cpu)))))
(define* (load-in-linux-vm builder
#:key
linux initrd
make-disk-image?
single-file-output?
- target-arm32?
(disk-image-size (* 100 (expt 2 20)))
(disk-image-format "qcow2")
(references-graphs '()))
REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
the #:references-graphs parameter of 'derivation'."
+ (define target-arm32?
+ (string-prefix? "arm-" %host-type))
+
+ (define target-aarch64?
+ (string-prefix? "aarch64-" %host-type))
+
+ (define target-arm?
+ (or target-arm32? target-aarch64?))
+
(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") '())
+ ,@(if target-arm?
+ '("-M" "virt")
+ '())
+
+ ;; On ARM32, if the kernel is built without LPAE support, ECAM conflicts
+ ;; with VIRT_PCIE_MMIO causing PCI devices not to show up. Disable
+ ;; explicitely highmem to fix it.
+ ;; See: https://bugs.launchpad.net/qemu/+bug/1790975.
+ ,@(if target-arm32?
+ '("-machine" "highmem=off")
+ '())
;; 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.
+ ;; still buggy on some ARM boards. Do not use it even if available.
,@(if (and (file-exists? "/dev/kvm")
- (not target-arm32?))
+ (not target-arm?))
'("-enable-kvm")
'())
+
+ ;; Pass "panic=1" so that the guest dies upon error.
"-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"))))
+ ,(string-append "panic=1 --load=" builder
+
+ ;; The serial port name differs between emulated
+ ;; architectures/machines.
+ " console="
+ (if target-arm? "ttyAMA0" "ttyS0"))))
(when make-disk-image?
(format #t "creating ~a image of ~,2f MiB...~%"
disk-image-format (/ disk-image-size (expt 2 20)))
(force-output)
- (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
- output
- (number->string disk-image-size)))
- (error "qemu-img failed")))
+ (invoke "qemu-img" "create" "-f" disk-image-format output
+ (number->string disk-image-size)))
(mkdir "xchg")
+ (mkdir "tmp")
(match references-graphs
((graph-files ...)
graph-files))
(_ #f))
- (unless (zero?
- (apply system* 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" (string-append "console=ttyS0 --load="
- builder)
- (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)))
- (error "qemu failed" qemu))
+ (apply invoke qemu "-nographic" "-no-reboot"
+ ;; CPU "max" behaves as "host" when KVM is enabled, and like a system
+ ;; CPU with the maximum possible feature set otherwise.
+ "-cpu" "max"
+ "-m" (number->string memory-size)
+ "-nic" "user,model=virtio-net-pci"
+ "-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")
+ "-virtfs"
+ ;; Some programs require more space in /tmp than is normally
+ ;; available in the guest. Accommodate such programs by sharing a
+ ;; temporary directory.
+ (string-append "local,id=tmp_dev,path=tmp"
+ ",security_model=none,mount_tag=tmp")
+ "-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))
+
+ (unless (file-exists? "xchg/.exit-status")
+ (error "VM did not produce an exit code"))
+
+ (match (call-with-input-file "xchg/.exit-status" read)
+ (0 #t)
+ (status (error "guest VM code exited with a non-zero status" status)))
+
+ (delete-file "xchg/.exit-status")
;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
(unless make-disk-image?
(mkdir output)
(copy-recursively "xchg" output)))))
+(define* (register-closure prefix closure
+ #:key
+ (deduplicate? #t) (reset-timestamps? #t)
+ (schema (sql-schema)))
+ "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
+target store and CLOSURE is the name of a file containing a reference graph as
+produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
+true, reset timestamps on store files and, if DEDUPLICATE? is true,
+deduplicates files common to CLOSURE and the rest of PREFIX."
+ (let ((items (call-with-input-file closure read-reference-graph)))
+ (parameterize ((sql-schema schema))
+ (with-database (store-database-file #:prefix prefix) db
+ (register-items db items
+ #:prefix prefix
+ #:deduplicate? deduplicate?
+ #:reset-timestamps? reset-timestamps?
+ #:registration-time %epoch)))))
+
\f
;;;
;;; Partitions.
(device partition-device (default #f))
(size partition-size)
(file-system partition-file-system (default "ext4"))
+ (file-system-options partition-file-system-options ;passed to 'mkfs.FS'
+ (default '()))
(label partition-label (default #f))
(uuid partition-uuid (default #f))
(flags partition-flags (default '()))
partition-size)
partitions)
", "))
- (unless (zero? (apply system* "parted" "--script"
- device "mklabel" label-type
- (options partitions offset)))
- (error "failed to create partition table"))
+ (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)
+ #:key label uuid (options '()))
"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)
- (unless (zero? (apply system* (string-append "mkfs." type)
- "-F" partition
- `(,@(if label
- `("-L" ,label)
- '())
- ,@(if uuid
- `("-U" ,(uuid->string uuid))
- '()))))
- (error "failed to create partition")))
+ (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n"
+ type label (and uuid (uuid->string uuid)))
+ (apply invoke (string-append "mkfs." type)
+ "-F" partition
+ `(,@(if label
+ `("-L" ,label)
+ '())
+ ,@(if uuid
+ `("-U" ,(uuid->string uuid))
+ '())
+ ,@options)))
(define* (create-fat-file-system partition
- #:key label uuid)
+ #:key label uuid (options '()))
"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")
- (unless (zero? (apply system* "mkfs.fat" partition
- (if label
- `("-n" ,label)
- '())))
- (error "failed to create FAT partition")))
+ (apply invoke "mkfs.fat" partition
+ (append (if label `("-n" ,label) '()) options)))
(define* (format-partition partition type
- #:key label uuid)
+ #:key label uuid (options '()))
"Create a file system TYPE on PARTITION. If LABEL is true, use that as the
-volume name."
+volume name. Options is a list of command-line options passed to 'mkfs.FS'."
(cond ((string-prefix? "ext" type)
- (create-ext-file-system partition type #:label label #:uuid uuid))
+ (create-ext-file-system partition type #:label label #:uuid uuid
+ #:options options))
((or (string-prefix? "fat" type) (string= "vfat" type))
- (create-fat-file-system partition #:label label #:uuid uuid))
+ (create-fat-file-system partition #:label label #:uuid uuid
+ #:options options))
(else (error "Unsupported file system."))))
(define (initialize-partition partition)
(format-partition (partition-device partition)
(partition-file-system partition)
#:label (partition-label partition)
- #:uuid (partition-uuid partition))
+ #:uuid (partition-uuid partition)
+ #:options (partition-file-system-options partition))
(mkdir-p target)
(mount (partition-device partition) target
(partition-file-system partition))
(define* (root-partition-initializer #:key (closures '())
copy-closures?
(register-closures? #t)
- system-directory)
+ system-directory
+ (deduplicate? #t)
+ (make-device-nodes
+ make-essential-device-nodes)
+ (extra-directives '()))
"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."
+If REGISTER-CLOSURES? is true, register all of CLOSURES in the partition's
+store. If DEDUPLICATE? is true, then also deduplicate files common to
+CLOSURES and the rest of the store when registering the closures. If
+COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
+SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation.
+
+EXTRA-DIRECTIVES is an optional list of directives to populate the root file
+system that is passed to 'populate-root-file-system'."
(lambda (target)
(define target-store
(string-append target (%store-directory)))
target))
;; Populate /dev.
- (make-essential-device-nodes #:root target)
+ (make-device-nodes 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
+ ;; XXX: 'register-closure' 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)))
+ (string-append "/xchg/" closure)
+ #:reset-timestamps? copy-closures?
+ #:deduplicate? deduplicate?))
closures)
(unless copy-closures?
(umount target-store)))
;; Add the non-store directories and files.
(display "populating...\n")
- (populate-root-file-system system-directory target)
+ (populate-root-file-system system-directory target
+ #:extras extra-directives)
- ;; 'guix-register' resets timestamps and everything, so no need to do it
+ ;; 'register-closure' resets timestamps and everything, so no need to do it
;; once more in that case.
(unless register-closures?
- (reset-timestamps target))))
+ ;; 'reset-timestamps' also resets file permissions; do that everywhere
+ ;; except on /dev so that /dev/null remains writable, etc.
+ (for-each (lambda (directory)
+ (reset-timestamps (string-append target "/" directory)))
+ (scandir target
+ (match-lambda
+ ((or "." ".." "dev") #f)
+ (_ #t))))
+ (reset-timestamps (string-append target "/dev")
+ #:preserve-permissions? #t))))
(define (register-bootcfg-root target bootcfg)
"On file system TARGET, register BOOTCFG as a GC root."
(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 "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)
- (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)
- 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))
-
- (unless (zero? (apply system*
- `(,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)))
- `()))))
- (error "failed to create ISO9660 image"))))
-
(define* (initialize-hard-disk device
#:key
bootloader-package
(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")))
+ (let ((mount-point (string-append target "/boot/efi")))
(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)
+ (install-efi-loader grub-efi mount-point)
(display "done.\n")
- (delete-file grub-config)
(umount mount-point)))
;; Register BOOTCFG as a GC root.
HCoop / jackhill / guix / guix.git / blobdiff