;;; 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 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>
#:use-module (guix build utils)
#:use-module (guix build store-copy)
#:use-module (guix build syscalls)
- #:use-module ((guix store database) #:select (reset-timestamps))
+ #:use-module (guix store database)
#:use-module (gnu build linux-boot)
#:use-module (gnu build install)
#:use-module (gnu system uuid)
#:use-module (ice-9 format)
#: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
(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
make-disk-image?
single-file-output?
target-arm32?
+ target-aarch64?
(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-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")
'())
;; 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"
(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)))
+ (register-items items
+ #:prefix prefix
+ #:deduplicate? deduplicate?
+ #:reset-timestamps? reset-timestamps?
+ #:registration-time %epoch
+ #:schema schema)))
+
\f
;;;
;;; Partitions.
;; 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)
+(define* (make-iso9660-image xorriso grub-mkrescue-environment
+ grub config-file os-drv target
+ #:key (volume-id "Guix_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)
- ;; TARGET-STORE is a read-only bind-mount so we shouldn't try
- ;; to modify it.
- #:deduplicate? #f
- #:reset-timestamps? #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 grub-mkrescue
+ (string-append grub "/bin/grub-mkrescue"))
+
+ (define grub-mkrescue-sed.sh
+ (string-append xorriso "/bin/grub-mkrescue-sed.sh"))
+
+ (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))
+
+ ;; 'grub-mkrescue' calls out to mtools programs to create 'efi.img', a FAT
+ ;; file system image, and mtools honors SOURCE_DATE_EPOCH for the mtime of
+ ;; those files. The epoch for FAT is Jan. 1st 1980, not 1970, so choose
+ ;; that.
+ (setenv "SOURCE_DATE_EPOCH"
+ (number->string
+ (time-second
+ (date->time-utc (make-date 0 0 0 0 1 1 1980 0)))))
+
+ ;; Our patched 'grub-mkrescue' honors this environment variable and passes
+ ;; it to 'mformat', which makes it the serial number of 'efi.img'. This
+ ;; allows for deterministic builds.
+ (setenv "GRUB_FAT_SERIAL_NUMBER"
+ (number->string (if volume-uuid
+
+ ;; On 32-bit systems the 2nd argument must be
+ ;; lower than 2^32.
+ (string-hash (iso9660-uuid->string volume-uuid)
+ (- (expt 2 32) 1))
+
+ #x77777777)
+ 16))
+
+ (setenv "MKRESCUE_SED_MODE" "original")
+ (setenv "MKRESCUE_SED_XORRISO" (string-append xorriso
+ "/bin/xorriso"))
+ (setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes")
+ (for-each (match-lambda
+ ((name . value) (setenv name value)))
+ grub-mkrescue-environment)
+
+ (let ((pipe
+ (apply open-pipe* OPEN_WRITE
+ grub-mkrescue
+ (string-append "--xorriso=" grub-mkrescue-sed.sh)
+ "-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" "-"
+ "--"
+
+ ;; Set all timestamps to 1.
+ "-volume_date" "all_file_dates" "=1"
+
+ "-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
(lambda (port)
(format port
"insmod part_msdos~@
- search --set=root --label GuixSD_image~@
+ search --set=root --label Guix_image~@
configfile /boot/grub/grub.cfg~%")))
(display "creating EFI firmware image...")
HCoop / jackhill / guix / guix.git / blobdiff