X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/a2278922fe5158d3caac9d2c3ff5008e084a45d3..f17f9984c372ff88ee8e8b6b5601f1be8dd4a2e6:/gnu/build/vm.scm diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 8f7fc3c9c4..7f6801b9dd 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2016 Christopher Allan Webber -;;; Copyright © 2016 Leo Famulari +;;; Copyright © 2016, 2017 Leo Famulari ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2017 Marius Bakke ;;; @@ -26,6 +26,7 @@ #: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) @@ -50,7 +51,8 @@ estimated-partition-size root-partition-initializer initialize-partition-table - initialize-hard-disk)) + initialize-hard-disk + make-iso9660-image)) ;;; Commentary: ;;; @@ -74,11 +76,15 @@ (qemu (qemu-command)) (memory-size 512) linux initrd 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 bytes resulting from the execution of BUILDER, which may @@ -86,14 +92,37 @@ 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 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? (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") @@ -105,38 +134,41 @@ the #:references-graphs parameter of 'derivation'." graph-files)) (_ #f)) - (unless (zero? - (apply system* qemu "-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) - (append - (if make-disk-image? - `("-drive" ,(string-append "file=" output - ",if=virtio")) - '()) - ;; 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") - '("-enable-kvm") - '())))) - (error "qemu failed" qemu)) + (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? - (mkdir output) - (copy-recursively "xchg" output))) + (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))))) ;;; @@ -149,14 +181,15 @@ the #:references-graphs parameter of 'derivation'." (size partition-size) (file-system partition-file-system (default "ext4")) (label partition-label (default #f)) + (uuid partition-uuid (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 20% overhead. - (round (* 1.2 (closure-size graphs)))) + ;; Simply add a 25% overhead. + (round (* 1.25 (closure-size graphs)))) (define* (initialize-partition-table device partitions #:key @@ -201,10 +234,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 @@ -222,37 +254,37 @@ actual /dev name based on DEVICE." (define MS_BIND 4096) ; 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." + #: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) - (unless (zero? (apply system* (string-append "mkfs." type) - "-F" partition - (if label - `("-L" ,label) - '()))) - (error "failed to create partition"))) + (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) - "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 + #: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") - (unless (zero? (apply system* "mkfs.fat" partition - (if label - `("-n" ,label) - '()))) - (error "failed to create FAT partition"))) + (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." (cond ((string-prefix? "ext" type) - (create-ext-file-system partition type #:label label)) + (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)) + (create-fat-file-system partition #:label label #:uuid uuid)) (else (error "Unsupported file system.")))) (define (initialize-partition partition) @@ -261,7 +293,8 @@ it, run its initializer, and unmount it." (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)) @@ -344,12 +377,53 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (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")))) + (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 @@ -401,11 +475,14 @@ passing it a directory name where it is mounted." ;; 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 gnu-disk-image~@ + search --set=root --label GuixSD_image~@ configfile /boot/grub/grub.cfg~%"))) (display "creating EFI firmware image...")