;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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 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?)
-
- ;; XXX: 32-bit 'qemu-system-i386 -enable-kvm' segfaults on
- ;; x86_64 hosts running Linux-libre 4.17:
- ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=31380#18> and
- ;; <https://lists.gnu.org/archive/html/qemu-devel/2018-07/msg01166.html>.
- (not (string-suffix? "-i386" qemu)))
+ (not target-arm?))
'("-enable-kvm")
'())
;; The serial port name differs between emulated
;; architectures/machines.
" console="
- (if target-arm32? "ttyAMA0" "ttyS0"))
-
- ;; 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"))))
+ (if target-arm? "ttyAMA0" "ttyS0"))))
(when make-disk-image?
(format #t "creating ~a image of ~,2f MiB...~%"
(_ #f))
(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"
'())
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?
(if single-file-output?
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)))
- (register-items items
- #:prefix prefix
- #:deduplicate? deduplicate?
- #:reset-timestamps? reset-timestamps?
- #:registration-time %epoch
- #:schema schema)))
+ (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
;;;
(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 '()))
(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... ~@[label: ~s~] ~@[uuid: ~s~]\n"
'())
,@(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")
(apply invoke "mkfs.fat" partition
- (if label `("-n" ,label) '())))
+ (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))
copy-closures?
(register-closures? #t)
system-directory
- (deduplicate? #t))
+ (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 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."
+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?
;; 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)
;; '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)
- (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."
- (define grub-mkrescue
- (string-append grub "/bin/grub-mkrescue"))
-
- (define target-store
- (string-append "/tmp/root" (%store-directory)))
-
- (define items
- ;; The store items to add to the image.
- (delete-duplicates
- (append-map (lambda (closure)
- (map store-info-item
- (call-with-input-file (string-append "/xchg/" closure)
- read-reference-graph)))
- closures)))
-
- (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)
-
- ;; TARGET-STORE is a read-only bind-mount so we shouldn't try
- ;; to modify it.
- #:deduplicate? #f
- #:reset-timestamps? #f))
- closures)
- (register-bootcfg-root "/tmp/root" config-file))
-
- (let ((pipe
- (apply open-pipe* OPEN_WRITE
- grub-mkrescue "-o" target
- (string-append "boot/grub/grub.cfg=" config-file)
- "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"
- "-path-list" "-"
- "--"
-
- ;; XXX: Add padding to avoid I/O errors on i686:
- ;; <https://bugs.gnu.org/33639>.
- "-padding" "10m"
-
- "-volid" (string-upcase volume-id)
- (if volume-uuid
- `("-volume_date" "uuid"
- ,(string-filter (lambda (value)
- (not (char=? #\- value)))
- (iso9660-uuid->string
- volume-uuid)))
- `()))))
- ;; Pass lines like 'gnu/store/…-x=/gnu/store/…-x' corresponding to the
- ;; '-path-list -' option.
- (for-each (lambda (item)
- (format pipe "~a=~a~%"
- (string-drop item 1) item))
- items)
- (unless (zero? (close-pipe pipe))
- (error "oh, my! grub-mkrescue failed" grub-mkrescue))))
-
(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