X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/162a13740041f907f0ce5c2aa05b52b162b4e81a..a45f8223e1a05ac3583708061209a1380b8a9d40:/gnu/build/vm.scm diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index fe003ea458..287d099f79 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -1,9 +1,11 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2016 Christopher Allan Webber ;;; Copyright © 2016, 2017 Leo Famulari ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2017 Marius Bakke +;;; Copyright © 2018 Chris Marusich +;;; Copyright © 2020 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,16 +26,21 @@ #: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 @@ -51,8 +58,7 @@ estimated-partition-size root-partition-initializer initialize-partition-table - initialize-hard-disk - make-iso9660-image)) + initialize-hard-disk)) ;;; Commentary: ;;; @@ -66,9 +72,10 @@ (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 @@ -77,7 +84,6 @@ linux initrd make-disk-image? single-file-output? - target-arm32? (disk-image-size (* 100 (expt 2 20))) (disk-image-format "qcow2") (references-graphs '())) @@ -93,40 +99,56 @@ 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 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 ...) @@ -136,31 +158,46 @@ the #:references-graphs parameter of 'derivation'." 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? @@ -176,6 +213,24 @@ the #:references-graphs parameter of 'derivation'." (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))))) + ;;; ;;; Partitions. @@ -186,6 +241,8 @@ the #:references-graphs parameter of 'derivation'." (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 '())) @@ -240,10 +297,9 @@ actual /dev name based on DEVICE." 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 @@ -261,41 +317,41 @@ actual /dev name based on DEVICE." (define MS_BIND 4096) ; 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) @@ -305,7 +361,8 @@ it, run its initializer, and unmount it." (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)) @@ -318,12 +375,21 @@ it, run its initializer, and unmount it." (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))) @@ -334,12 +400,12 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." 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)) @@ -347,19 +413,31 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (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." @@ -367,77 +445,6 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (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 @@ -479,30 +486,16 @@ passing it a directory name where it is mounted." (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.