2014-04-11 11:38:11 +00:00
|
|
|
|
;;; GNU Guix --- Functional package management for GNU
|
2019-03-13 15:44:02 +00:00
|
|
|
|
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
|
2016-02-22 19:23:14 +00:00
|
|
|
|
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
|
2017-12-03 01:17:45 +00:00
|
|
|
|
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
|
2017-04-15 12:22:24 +00:00
|
|
|
|
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
2017-04-11 08:47:38 +00:00
|
|
|
|
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
|
2018-03-15 04:09:11 +00:00
|
|
|
|
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
|
2014-04-11 11:38:11 +00:00
|
|
|
|
;;;
|
|
|
|
|
;;; This file is part of GNU Guix.
|
|
|
|
|
;;;
|
|
|
|
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
|
|
|
|
;;; under the terms of the GNU General Public License as published by
|
|
|
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
|
|
|
;;; your option) any later version.
|
|
|
|
|
;;;
|
|
|
|
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
|
|
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
;;; GNU General Public License for more details.
|
|
|
|
|
;;;
|
|
|
|
|
;;; You should have received a copy of the GNU General Public License
|
|
|
|
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
2014-09-03 08:47:05 +00:00
|
|
|
|
(define-module (gnu build vm)
|
2014-04-11 11:38:11 +00:00
|
|
|
|
#:use-module (guix build utils)
|
2014-09-04 21:05:12 +00:00
|
|
|
|
#:use-module (guix build store-copy)
|
2017-04-06 06:55:45 +00:00
|
|
|
|
#:use-module (guix build syscalls)
|
2018-10-27 22:17:08 +00:00
|
|
|
|
#:use-module (guix store database)
|
2014-09-03 09:14:12 +00:00
|
|
|
|
#:use-module (gnu build linux-boot)
|
2014-09-03 08:47:05 +00:00
|
|
|
|
#:use-module (gnu build install)
|
file-systems: Introduce (gnu system uuid).
* gnu/build/file-systems.scm (sub-bytevector)
(latin1->string, %fat32-endianness, fat32-uuid->string)
(%iso9660-uuid-rx, string->iso9660-uuid)
(iso9660-uuid->string, %network-byte-order)
(dce-uuid->string, %uuid-rx, string->dce-uuid)
(string->ext2-uuid, string->ext3-uuid, string->ext4-uuid)
(vhashq, %uuid-parsers, %uuid-printers, string->uuid)
(uuid->string): Move to...
* gnu/system/uuid.scm: ... here. New file.
* gnu/system/file-systems.scm (uuid): Move to the above file.
* gnu/system/vm.scm: Adjust accordingly.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add uuid.scm.
2017-09-05 19:51:12 +00:00
|
|
|
|
#:use-module (gnu system uuid)
|
2015-07-25 21:57:52 +00:00
|
|
|
|
#:use-module (guix records)
|
2017-06-29 22:13:54 +00:00
|
|
|
|
#:use-module ((guix combinators) #:select (fold2))
|
2017-05-07 13:31:30 +00:00
|
|
|
|
#:use-module (ice-9 format)
|
2014-04-11 16:44:53 +00:00
|
|
|
|
#:use-module (ice-9 match)
|
2014-07-13 14:07:26 +00:00
|
|
|
|
#:use-module (ice-9 regex)
|
2018-06-26 11:47:30 +00:00
|
|
|
|
#:use-module (ice-9 popen)
|
2015-07-25 21:57:52 +00:00
|
|
|
|
#:use-module (srfi srfi-1)
|
|
|
|
|
#:use-module (srfi srfi-9)
|
2019-04-20 20:34:28 +00:00
|
|
|
|
#:use-module (srfi srfi-19)
|
2014-04-11 16:44:53 +00:00
|
|
|
|
#:use-module (srfi srfi-26)
|
2014-07-13 14:07:26 +00:00
|
|
|
|
#:export (qemu-command
|
|
|
|
|
load-in-linux-vm
|
2014-05-21 21:31:46 +00:00
|
|
|
|
format-partition
|
2015-07-25 21:57:52 +00:00
|
|
|
|
|
|
|
|
|
partition
|
|
|
|
|
partition?
|
|
|
|
|
partition-device
|
|
|
|
|
partition-size
|
|
|
|
|
partition-file-system
|
|
|
|
|
partition-label
|
2017-04-11 08:47:38 +00:00
|
|
|
|
partition-flags
|
2015-07-25 21:57:52 +00:00
|
|
|
|
partition-initializer
|
|
|
|
|
|
2017-06-29 22:04:38 +00:00
|
|
|
|
estimated-partition-size
|
2015-07-25 21:57:52 +00:00
|
|
|
|
root-partition-initializer
|
2014-05-21 21:31:46 +00:00
|
|
|
|
initialize-partition-table
|
2017-07-03 08:05:03 +00:00
|
|
|
|
initialize-hard-disk
|
|
|
|
|
make-iso9660-image))
|
2014-04-11 11:38:11 +00:00
|
|
|
|
|
|
|
|
|
;;; Commentary:
|
|
|
|
|
;;;
|
|
|
|
|
;;; This module provides supporting code to run virtual machines and build
|
|
|
|
|
;;; virtual machine images using QEMU.
|
|
|
|
|
;;;
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
2014-07-13 14:07:26 +00:00
|
|
|
|
(define* (qemu-command #:optional (system %host-type))
|
|
|
|
|
"Return the default name of the QEMU command for SYSTEM."
|
2016-06-20 21:03:08 +00:00
|
|
|
|
(let ((cpu (substring system 0
|
|
|
|
|
(string-index system #\-))))
|
2014-07-13 14:07:26 +00:00
|
|
|
|
(string-append "qemu-system-"
|
|
|
|
|
(if (string-match "^i[3456]86$" cpu)
|
|
|
|
|
"i386"
|
|
|
|
|
cpu))))
|
2014-04-11 11:38:11 +00:00
|
|
|
|
|
|
|
|
|
(define* (load-in-linux-vm builder
|
|
|
|
|
#:key
|
|
|
|
|
output
|
|
|
|
|
(qemu (qemu-command)) (memory-size 512)
|
|
|
|
|
linux initrd
|
2017-06-29 21:11:23 +00:00
|
|
|
|
make-disk-image?
|
2017-07-18 19:38:16 +00:00
|
|
|
|
single-file-output?
|
2017-12-05 10:34:01 +00:00
|
|
|
|
target-arm32?
|
2019-08-20 16:00:40 +00:00
|
|
|
|
target-aarch64?
|
2017-06-29 21:11:23 +00:00
|
|
|
|
(disk-image-size (* 100 (expt 2 20)))
|
2014-05-22 20:30:13 +00:00
|
|
|
|
(disk-image-format "qcow2")
|
2014-04-11 11:38:11 +00:00
|
|
|
|
(references-graphs '()))
|
|
|
|
|
"Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
|
2017-07-18 19:38:16 +00:00
|
|
|
|
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.
|
2014-04-11 11:38:11 +00:00
|
|
|
|
|
|
|
|
|
When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
|
2017-06-29 21:11:23 +00:00
|
|
|
|
DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
|
|
|
|
|
access it via /dev/hda.
|
2014-04-11 11:38:11 +00:00
|
|
|
|
|
|
|
|
|
REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
|
|
|
|
|
the #:references-graphs parameter of 'derivation'."
|
2017-12-05 10:34:01 +00:00
|
|
|
|
|
2019-08-20 16:00:40 +00:00
|
|
|
|
(define target-arm? (or target-arm32? target-aarch64?))
|
|
|
|
|
|
2017-12-05 10:34:01 +00:00
|
|
|
|
(define arch-specific-flags
|
|
|
|
|
`(;; On ARM, a machine has to be specified. Use "virt" machine to avoid
|
|
|
|
|
;; hardware limits imposed by other machines.
|
2019-08-20 16:00:40 +00:00
|
|
|
|
,@(if target-arm?
|
|
|
|
|
'("-M" "virt")
|
|
|
|
|
'())
|
2017-12-05 10:34:01 +00:00
|
|
|
|
|
2019-08-23 07:51:33 +00:00
|
|
|
|
;; 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")
|
|
|
|
|
'())
|
|
|
|
|
|
2017-12-05 10:34:01 +00:00
|
|
|
|
;; Only enable kvm if we see /dev/kvm exists. This allows users without
|
|
|
|
|
;; hardware virtualization to still use these commands. KVM support is
|
2019-08-20 16:00:40 +00:00
|
|
|
|
;; still buggy on some ARM boards. Do not use it even if available.
|
2017-12-05 10:34:01 +00:00
|
|
|
|
,@(if (and (file-exists? "/dev/kvm")
|
2019-08-20 16:00:40 +00:00
|
|
|
|
(not target-arm?))
|
2017-12-05 10:34:01 +00:00
|
|
|
|
'("-enable-kvm")
|
|
|
|
|
'())
|
2018-05-25 10:04:22 +00:00
|
|
|
|
|
|
|
|
|
;; Pass "panic=1" so that the guest dies upon error.
|
2017-12-05 10:34:01 +00:00
|
|
|
|
"-append"
|
2018-05-25 10:04:22 +00:00
|
|
|
|
,(string-append "panic=1 --load=" builder
|
|
|
|
|
|
|
|
|
|
;; The serial port name differs between emulated
|
|
|
|
|
;; architectures/machines.
|
|
|
|
|
" console="
|
2019-08-20 16:00:40 +00:00
|
|
|
|
(if target-arm? "ttyAMA0" "ttyS0"))
|
2018-05-25 10:04:22 +00:00
|
|
|
|
|
2017-12-05 10:34:01 +00:00
|
|
|
|
;; NIC is not supported on ARM "virt" machine, so use a user mode
|
|
|
|
|
;; network stack instead.
|
2019-08-20 16:00:40 +00:00
|
|
|
|
,@(if target-arm?
|
2017-12-05 10:34:01 +00:00
|
|
|
|
'("-device" "virtio-net-pci,netdev=mynet"
|
|
|
|
|
"-netdev" "user,id=mynet")
|
|
|
|
|
'("-net" "nic,model=virtio"))))
|
|
|
|
|
|
2014-04-11 11:38:11 +00:00
|
|
|
|
(when make-disk-image?
|
2017-06-29 21:26:35 +00:00
|
|
|
|
(format #t "creating ~a image of ~,2f MiB...~%"
|
|
|
|
|
disk-image-format (/ disk-image-size (expt 2 20)))
|
|
|
|
|
(force-output)
|
2018-03-15 15:30:41 +00:00
|
|
|
|
(invoke "qemu-img" "create" "-f" disk-image-format output
|
|
|
|
|
(number->string disk-image-size)))
|
2014-04-11 11:38:11 +00:00
|
|
|
|
|
|
|
|
|
(mkdir "xchg")
|
2018-03-15 04:09:12 +00:00
|
|
|
|
(mkdir "tmp")
|
2014-04-11 11:38:11 +00:00
|
|
|
|
|
|
|
|
|
(match references-graphs
|
|
|
|
|
((graph-files ...)
|
|
|
|
|
;; Copy the reference-graph files under xchg/ so EXP can access it.
|
|
|
|
|
(map (lambda (file)
|
|
|
|
|
(copy-file file (string-append "xchg/" file)))
|
|
|
|
|
graph-files))
|
|
|
|
|
(_ #f))
|
|
|
|
|
|
2018-03-15 15:30:41 +00:00
|
|
|
|
(apply invoke qemu "-nographic" "-no-reboot"
|
2019-08-20 16:00:40 +00:00
|
|
|
|
;; CPU "max" behaves as "host" when KVM is enabled, and like a system
|
|
|
|
|
;; CPU with the maximum possible feature set otherwise.
|
|
|
|
|
"-cpu" "max"
|
2018-03-15 15:30:41 +00:00
|
|
|
|
"-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")
|
2018-03-15 04:09:12 +00:00
|
|
|
|
"-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")
|
2018-03-15 15:30:41 +00:00
|
|
|
|
"-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))
|
2014-04-11 11:38:11 +00:00
|
|
|
|
|
2016-11-28 21:56:41 +00:00
|
|
|
|
;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
|
|
|
|
|
(unless make-disk-image?
|
2017-07-18 19:38:16 +00:00
|
|
|
|
(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)))))
|
2014-04-11 11:38:11 +00:00
|
|
|
|
|
2018-10-27 22:17:08 +00:00
|
|
|
|
(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)))
|
|
|
|
|
|
2015-07-25 21:57:52 +00:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Partitions.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define-record-type* <partition> partition make-partition
|
|
|
|
|
partition?
|
|
|
|
|
(device partition-device (default #f))
|
|
|
|
|
(size partition-size)
|
|
|
|
|
(file-system partition-file-system (default "ext4"))
|
|
|
|
|
(label partition-label (default #f))
|
2017-07-19 22:15:43 +00:00
|
|
|
|
(uuid partition-uuid (default #f))
|
2017-04-11 08:47:38 +00:00
|
|
|
|
(flags partition-flags (default '()))
|
2015-07-25 21:57:52 +00:00
|
|
|
|
(initializer partition-initializer (default (const #t))))
|
|
|
|
|
|
2017-06-29 22:04:38 +00:00
|
|
|
|
(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."
|
2017-07-18 14:30:14 +00:00
|
|
|
|
;; Simply add a 25% overhead.
|
|
|
|
|
(round (* 1.25 (closure-size graphs))))
|
2017-06-29 22:04:38 +00:00
|
|
|
|
|
2015-07-25 21:57:52 +00:00
|
|
|
|
(define* (initialize-partition-table device partitions
|
2014-04-11 16:44:53 +00:00
|
|
|
|
#:key
|
|
|
|
|
(label-type "msdos")
|
2014-05-21 21:31:46 +00:00
|
|
|
|
(offset (expt 2 20)))
|
2015-07-25 21:57:52 +00:00
|
|
|
|
"Create on DEVICE a partition table of type LABEL-TYPE, containing the given
|
|
|
|
|
PARTITIONS (a list of <partition> objects), starting at OFFSET bytes. On
|
|
|
|
|
success, return PARTITIONS with their 'device' field changed to reflect their
|
|
|
|
|
actual /dev name based on DEVICE."
|
|
|
|
|
(define (partition-options part offset index)
|
|
|
|
|
(cons* "mkpart" "primary" "ext2"
|
|
|
|
|
(format #f "~aB" offset)
|
|
|
|
|
(format #f "~aB" (+ offset (partition-size part)))
|
2017-04-11 08:47:38 +00:00
|
|
|
|
(append-map (lambda (flag)
|
|
|
|
|
(list "set" (number->string index)
|
|
|
|
|
(symbol->string flag) "on"))
|
|
|
|
|
(partition-flags part))))
|
2015-07-25 21:57:52 +00:00
|
|
|
|
|
|
|
|
|
(define (options partitions offset)
|
|
|
|
|
(let loop ((partitions partitions)
|
|
|
|
|
(offset offset)
|
|
|
|
|
(index 1)
|
|
|
|
|
(result '()))
|
|
|
|
|
(match partitions
|
|
|
|
|
(()
|
|
|
|
|
(concatenate (reverse result)))
|
|
|
|
|
((head tail ...)
|
|
|
|
|
(loop tail
|
|
|
|
|
;; Leave one sector (512B) between partitions to placate
|
|
|
|
|
;; Parted.
|
|
|
|
|
(+ offset 512 (partition-size head))
|
|
|
|
|
(+ 1 index)
|
|
|
|
|
(cons (partition-options head offset index)
|
|
|
|
|
result))))))
|
|
|
|
|
|
2017-06-29 21:26:35 +00:00
|
|
|
|
(format #t "creating partition table with ~a partitions (~a)...\n"
|
|
|
|
|
(length partitions)
|
|
|
|
|
(string-join (map (compose (cut string-append <> " MiB")
|
|
|
|
|
number->string
|
|
|
|
|
(lambda (size)
|
|
|
|
|
(round (/ size (expt 2. 20))))
|
|
|
|
|
partition-size)
|
|
|
|
|
partitions)
|
|
|
|
|
", "))
|
2018-03-15 15:30:41 +00:00
|
|
|
|
(apply invoke "parted" "--script"
|
|
|
|
|
device "mklabel" label-type
|
|
|
|
|
(options partitions offset))
|
2015-07-25 21:57:52 +00:00
|
|
|
|
|
|
|
|
|
;; Set the 'device' field of each partition.
|
|
|
|
|
(reverse
|
|
|
|
|
(fold2 (lambda (part result index)
|
|
|
|
|
(values (cons (partition
|
|
|
|
|
(inherit part)
|
|
|
|
|
(device (string-append device
|
|
|
|
|
(number->string index))))
|
|
|
|
|
result)
|
|
|
|
|
(+ 1 index)))
|
|
|
|
|
'()
|
|
|
|
|
1
|
|
|
|
|
partitions)))
|
2014-04-11 16:44:53 +00:00
|
|
|
|
|
2014-05-15 20:55:14 +00:00
|
|
|
|
(define MS_BIND 4096) ; <sys/mounts.h> again!
|
|
|
|
|
|
2017-05-06 20:53:58 +00:00
|
|
|
|
(define* (create-ext-file-system partition type
|
2017-07-19 22:15:43 +00:00
|
|
|
|
#:key label uuid)
|
2018-01-19 15:25:13 +00:00
|
|
|
|
"Create an ext-family file system of TYPE on PARTITION. If LABEL is true,
|
2017-07-19 22:15:43 +00:00
|
|
|
|
use that as the volume name. If UUID is true, use it as the partition UUID."
|
2018-05-23 08:14:20 +00:00
|
|
|
|
(format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n"
|
|
|
|
|
type label (and uuid (uuid->string uuid)))
|
2018-03-15 15:30:41 +00:00
|
|
|
|
(apply invoke (string-append "mkfs." type)
|
|
|
|
|
"-F" partition
|
|
|
|
|
`(,@(if label
|
|
|
|
|
`("-L" ,label)
|
|
|
|
|
'())
|
|
|
|
|
,@(if uuid
|
|
|
|
|
`("-U" ,(uuid->string uuid))
|
|
|
|
|
'()))))
|
2014-05-15 20:55:14 +00:00
|
|
|
|
|
2017-05-06 20:53:58 +00:00
|
|
|
|
(define* (create-fat-file-system partition
|
2017-07-19 22:15:43 +00:00
|
|
|
|
#:key label uuid)
|
2018-01-19 15:25:13 +00:00
|
|
|
|
"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
|
2017-05-06 20:53:58 +00:00
|
|
|
|
volume name."
|
2017-07-19 22:15:43 +00:00
|
|
|
|
;; FIXME: UUID is ignored!
|
2017-05-06 20:53:58 +00:00
|
|
|
|
(format #t "creating FAT partition...\n")
|
2018-03-15 15:30:41 +00:00
|
|
|
|
(apply invoke "mkfs.fat" partition
|
|
|
|
|
(if label `("-n" ,label) '())))
|
2017-05-06 20:53:58 +00:00
|
|
|
|
|
|
|
|
|
(define* (format-partition partition type
|
2017-07-19 22:15:43 +00:00
|
|
|
|
#:key label uuid)
|
2017-05-06 20:53:58 +00:00
|
|
|
|
"Create a file system TYPE on PARTITION. If LABEL is true, use that as the
|
|
|
|
|
volume name."
|
|
|
|
|
(cond ((string-prefix? "ext" type)
|
2017-07-19 22:15:43 +00:00
|
|
|
|
(create-ext-file-system partition type #:label label #:uuid uuid))
|
2017-05-06 20:53:58 +00:00
|
|
|
|
((or (string-prefix? "fat" type) (string= "vfat" type))
|
2017-07-19 22:15:43 +00:00
|
|
|
|
(create-fat-file-system partition #:label label #:uuid uuid))
|
2017-05-06 20:53:58 +00:00
|
|
|
|
(else (error "Unsupported file system."))))
|
|
|
|
|
|
2015-07-25 21:57:52 +00:00
|
|
|
|
(define (initialize-partition partition)
|
|
|
|
|
"Format PARTITION, a <partition> object with a non-#f 'device' field, mount
|
|
|
|
|
it, run its initializer, and unmount it."
|
|
|
|
|
(let ((target "/fs"))
|
|
|
|
|
(format-partition (partition-device partition)
|
|
|
|
|
(partition-file-system partition)
|
2017-07-19 22:15:43 +00:00
|
|
|
|
#:label (partition-label partition)
|
|
|
|
|
#:uuid (partition-uuid partition))
|
2015-07-25 21:57:52 +00:00
|
|
|
|
(mkdir-p target)
|
|
|
|
|
(mount (partition-device partition) target
|
|
|
|
|
(partition-file-system partition))
|
|
|
|
|
|
|
|
|
|
((partition-initializer partition) target)
|
|
|
|
|
|
|
|
|
|
(umount target)
|
|
|
|
|
partition))
|
|
|
|
|
|
|
|
|
|
(define* (root-partition-initializer #:key (closures '())
|
|
|
|
|
copy-closures?
|
|
|
|
|
(register-closures? #t)
|
2018-03-15 04:09:11 +00:00
|
|
|
|
system-directory
|
|
|
|
|
(deduplicate? #t))
|
2015-07-25 21:57:52 +00:00
|
|
|
|
"Return a procedure to initialize a root partition.
|
|
|
|
|
|
2018-03-15 04:09:11 +00:00
|
|
|
|
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.
|
2015-07-25 21:57:52 +00:00
|
|
|
|
SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
|
|
|
|
|
(lambda (target)
|
|
|
|
|
(define target-store
|
|
|
|
|
(string-append target (%store-directory)))
|
|
|
|
|
|
|
|
|
|
(when copy-closures?
|
|
|
|
|
;; Populate the store.
|
|
|
|
|
(populate-store (map (cut string-append "/xchg/" <>) closures)
|
|
|
|
|
target))
|
|
|
|
|
|
|
|
|
|
;; Populate /dev.
|
|
|
|
|
(make-essential-device-nodes #:root target)
|
|
|
|
|
|
|
|
|
|
;; Optionally, register the inputs in the image's store.
|
|
|
|
|
(when register-closures?
|
|
|
|
|
(unless copy-closures?
|
2018-06-08 09:03:31 +00:00
|
|
|
|
;; XXX: 'register-closure' wants to palpate the things it registers, so
|
2015-07-25 21:57:52 +00:00
|
|
|
|
;; 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
|
2018-03-15 04:09:11 +00:00
|
|
|
|
(string-append "/xchg/" closure)
|
2018-06-06 21:58:18 +00:00
|
|
|
|
#:reset-timestamps? copy-closures?
|
2018-03-15 04:09:11 +00:00
|
|
|
|
#:deduplicate? deduplicate?))
|
2015-07-25 21:57:52 +00:00
|
|
|
|
closures)
|
|
|
|
|
(unless copy-closures?
|
|
|
|
|
(umount target-store)))
|
|
|
|
|
|
|
|
|
|
;; Add the non-store directories and files.
|
|
|
|
|
(display "populating...\n")
|
|
|
|
|
(populate-root-file-system system-directory target)
|
|
|
|
|
|
2018-06-08 09:03:31 +00:00
|
|
|
|
;; 'register-closure' resets timestamps and everything, so no need to do it
|
2015-07-25 21:57:52 +00:00
|
|
|
|
;; once more in that case.
|
|
|
|
|
(unless register-closures?
|
|
|
|
|
(reset-timestamps target))))
|
2014-05-21 21:31:46 +00:00
|
|
|
|
|
2017-05-09 08:52:02 +00:00
|
|
|
|
(define (register-bootcfg-root target bootcfg)
|
2017-04-15 12:22:24 +00:00
|
|
|
|
"On file system TARGET, register BOOTCFG as a GC root."
|
2014-12-09 10:06:22 +00:00
|
|
|
|
(let ((directory (string-append target "/var/guix/gcroots")))
|
2014-12-04 22:52:28 +00:00
|
|
|
|
(mkdir-p directory)
|
2017-05-09 08:52:02 +00:00
|
|
|
|
(symlink bootcfg (string-append directory "/bootcfg"))))
|
2014-12-04 22:52:28 +00:00
|
|
|
|
|
2017-05-07 13:31:30 +00:00
|
|
|
|
(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)
|
2018-03-15 15:30:41 +00:00
|
|
|
|
(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))))
|
2017-05-07 13:31:30 +00:00
|
|
|
|
|
2019-05-18 15:49:05 +00:00
|
|
|
|
(define* (make-iso9660-image xorriso grub-mkrescue-environment
|
|
|
|
|
grub config-file os-drv target
|
2019-03-13 15:44:02 +00:00
|
|
|
|
#:key (volume-id "Guix_image") (volume-uuid #f)
|
2017-09-03 10:47:58 +00:00
|
|
|
|
register-closures? (closures '()))
|
2017-07-03 08:05:03 +00:00
|
|
|
|
"Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
|
2017-07-18 19:38:16 +00:00
|
|
|
|
GRUB configuration and OS-DRV as the stuff in it."
|
2018-06-26 11:47:30 +00:00
|
|
|
|
(define grub-mkrescue
|
|
|
|
|
(string-append grub "/bin/grub-mkrescue"))
|
|
|
|
|
|
2019-05-18 15:49:05 +00:00
|
|
|
|
(define grub-mkrescue-sed.sh
|
|
|
|
|
(string-append xorriso "/bin/grub-mkrescue-sed.sh"))
|
|
|
|
|
|
2018-06-26 11:47:30 +00:00
|
|
|
|
(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))
|
2018-06-26 12:22:27 +00:00
|
|
|
|
closures)
|
|
|
|
|
(register-bootcfg-root "/tmp/root" config-file))
|
2018-06-26 11:47:30 +00:00
|
|
|
|
|
2019-04-20 20:34:28 +00:00
|
|
|
|
;; '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)))))
|
|
|
|
|
|
2019-04-20 22:16:57 +00:00
|
|
|
|
;; 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
|
2019-04-24 22:43:42 +00:00
|
|
|
|
|
|
|
|
|
;; On 32-bit systems the 2nd argument must be
|
|
|
|
|
;; lower than 2^32.
|
2019-04-20 22:16:57 +00:00
|
|
|
|
(string-hash (iso9660-uuid->string volume-uuid)
|
2019-04-24 22:43:42 +00:00
|
|
|
|
(- (expt 2 32) 1))
|
|
|
|
|
|
2019-04-20 22:16:57 +00:00
|
|
|
|
#x77777777)
|
|
|
|
|
16))
|
|
|
|
|
|
2019-05-18 15:49:05 +00:00
|
|
|
|
(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)
|
|
|
|
|
|
2018-06-26 11:47:30 +00:00
|
|
|
|
(let ((pipe
|
|
|
|
|
(apply open-pipe* OPEN_WRITE
|
2019-05-18 15:49:05 +00:00
|
|
|
|
grub-mkrescue
|
|
|
|
|
(string-append "--xorriso=" grub-mkrescue-sed.sh)
|
|
|
|
|
"-o" target
|
2018-06-26 11:47:30 +00:00
|
|
|
|
(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" "-"
|
|
|
|
|
"--"
|
2019-04-20 12:42:53 +00:00
|
|
|
|
|
|
|
|
|
;; Set all timestamps to 1.
|
|
|
|
|
"-volume_date" "all_file_dates" "=1"
|
|
|
|
|
|
2018-06-26 11:47:30 +00:00
|
|
|
|
"-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))))
|
2017-07-03 08:05:03 +00:00
|
|
|
|
|
2014-05-21 21:31:46 +00:00
|
|
|
|
(define* (initialize-hard-disk device
|
|
|
|
|
#:key
|
2017-05-09 08:52:02 +00:00
|
|
|
|
bootloader-package
|
|
|
|
|
bootcfg
|
|
|
|
|
bootcfg-location
|
|
|
|
|
bootloader-installer
|
2017-05-07 13:31:30 +00:00
|
|
|
|
(grub-efi #f)
|
2015-07-25 21:57:52 +00:00
|
|
|
|
(partitions '()))
|
|
|
|
|
"Initialize DEVICE as a disk containing all the <partition> objects listed
|
2017-04-15 12:22:24 +00:00
|
|
|
|
in PARTITIONS, and using BOOTCFG as its bootloader configuration file.
|
2014-05-21 21:31:46 +00:00
|
|
|
|
|
2015-07-25 21:57:52 +00:00
|
|
|
|
Each partition is initialized by calling its 'initializer' procedure,
|
|
|
|
|
passing it a directory name where it is mounted."
|
2017-04-11 08:47:38 +00:00
|
|
|
|
|
|
|
|
|
(define (partition-bootable? partition)
|
|
|
|
|
"Return the first partition found with the boot flag set."
|
|
|
|
|
(member 'boot (partition-flags partition)))
|
|
|
|
|
|
2017-05-07 13:31:30 +00:00
|
|
|
|
(define (partition-esp? partition)
|
|
|
|
|
"Return the first EFI System Partition."
|
|
|
|
|
(member 'esp (partition-flags partition)))
|
|
|
|
|
|
2015-07-25 21:57:52 +00:00
|
|
|
|
(let* ((partitions (initialize-partition-table device partitions))
|
|
|
|
|
(root (find partition-bootable? partitions))
|
2017-05-07 13:31:30 +00:00
|
|
|
|
(esp (find partition-esp? partitions))
|
2015-07-25 21:57:52 +00:00
|
|
|
|
(target "/fs"))
|
|
|
|
|
(unless root
|
|
|
|
|
(error "no bootable partition specified" partitions))
|
2014-04-11 16:44:53 +00:00
|
|
|
|
|
2015-07-25 21:57:52 +00:00
|
|
|
|
(for-each initialize-partition partitions)
|
2014-04-11 16:44:53 +00:00
|
|
|
|
|
2015-07-25 21:57:52 +00:00
|
|
|
|
(display "mounting root partition...\n")
|
|
|
|
|
(mkdir-p target)
|
|
|
|
|
(mount (partition-device root) target (partition-file-system root))
|
2017-05-09 08:52:02 +00:00
|
|
|
|
(install-boot-config bootcfg bootcfg-location target)
|
|
|
|
|
(when bootloader-installer
|
2017-05-07 13:31:30 +00:00
|
|
|
|
(display "installing bootloader...\n")
|
2017-05-09 08:52:02 +00:00
|
|
|
|
(bootloader-installer bootloader-package device target))
|
2014-12-04 22:52:28 +00:00
|
|
|
|
|
2017-05-07 13:31:30 +00:00
|
|
|
|
(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")))
|
|
|
|
|
(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.
|
2017-07-14 18:47:38 +00:00
|
|
|
|
;; 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).
|
2017-05-07 13:31:30 +00:00
|
|
|
|
(call-with-output-file grub-config
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(format port
|
|
|
|
|
"insmod part_msdos~@
|
2019-03-13 15:44:02 +00:00
|
|
|
|
search --set=root --label Guix_image~@
|
2017-05-07 13:31:30 +00:00
|
|
|
|
configfile /boot/grub/grub.cfg~%")))
|
|
|
|
|
|
|
|
|
|
(display "creating EFI firmware image...")
|
|
|
|
|
(install-efi grub-efi mount-point grub-config)
|
|
|
|
|
(display "done.\n")
|
|
|
|
|
|
|
|
|
|
(delete-file grub-config)
|
|
|
|
|
(umount mount-point)))
|
|
|
|
|
|
2017-05-09 08:52:02 +00:00
|
|
|
|
;; Register BOOTCFG as a GC root.
|
|
|
|
|
(register-bootcfg-root target bootcfg)
|
2014-04-11 16:44:53 +00:00
|
|
|
|
|
2015-07-25 21:57:52 +00:00
|
|
|
|
(umount target)))
|
2014-04-11 16:44:53 +00:00
|
|
|
|
|
2014-04-11 11:38:11 +00:00
|
|
|
|
;;; vm.scm ends here
|