@@ -10173,11 +10173,11 @@ headers, which comes in handy in this case:
(with-imported-modules (source-module-closure
'((guix build utils)
- (gnu build vm)))
+ (gnu build image)))
(gexp->derivation "something-with-vms"
#~(begin
(use-modules (guix build utils)
- (gnu build vm))
+ (gnu build image))
@dots{})))
@end lisp
@@ -24,6 +24,7 @@ (define-module (gnu build marionette)
#:use-module (rnrs io ports)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
+ #:use-module (ice-9 regex)
#:export (marionette?
make-marionette
marionette-eval
@@ -36,7 +37,8 @@ (define-module (gnu build marionette)
%qwerty-us-keystrokes
marionette-type
- system-test-runner))
+ system-test-runner
+ qemu-command))
;;; Commentary:
;;;
@@ -426,4 +428,14 @@ (define* (system-test-runner #:optional log-directory)
(exit success?))))
runner))
+(define* (qemu-command #:optional (system %host-type))
+ "Return the default name of the QEMU command for SYSTEM."
+ (let ((cpu (substring system 0
+ (string-index system #\-))))
+ (string-append "qemu-system-"
+ (cond
+ ((string-match "^i[3456]86$" cpu) "i386")
+ ((string-match "armhf" cpu) "arm")
+ (else cpu)))))
+
;;; marionette.scm ends here
deleted file mode 100644
@@ -1,500 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2016 Christine Lemmer-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.
-;;;
-;;; 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/>.
-
-(define-module (gnu build vm)
- #: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
- format-partition
-
- partition
- partition?
- partition-device
- partition-size
- partition-file-system
- partition-label
- partition-flags
- partition-initializer
-
- estimated-partition-size
- root-partition-initializer
- initialize-partition-table
- initialize-hard-disk))
-
-;;; Commentary:
-;;;
-;;; This module provides supporting code to run virtual machines and build
-;;; virtual machine images using QEMU.
-;;;
-;;; Code:
-
-(define* (qemu-command #:optional (system %host-type))
- "Return the default name of the QEMU command for SYSTEM."
- (let ((cpu (substring system 0
- (string-index system #\-))))
- (string-append "qemu-system-"
- (cond
- ((string-match "^i[3456]86$" cpu) "i386")
- ((string-match "armhf" cpu) "arm")
- (else cpu)))))
-
-(define* (load-in-linux-vm builder
- #:key
- output
- (qemu (qemu-command)) (memory-size 512)
- linux initrd
- make-disk-image?
- single-file-output?
- (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. 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
-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-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 ARM boards. Do not use it even if available.
- ,@(if (and (file-exists? "/dev/kvm")
- (not target-arm?))
- '("-enable-kvm")
- '())
-
- ;; Pass "panic=1" so that the guest dies upon error.
- "-append"
- ,(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)
- (invoke "qemu-img" "create" "-f" disk-image-format output
- (number->string disk-image-size)))
-
- (mkdir "xchg")
- (mkdir "tmp")
-
- (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))
-
- (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=guix-vm-rng"
- "-device" "virtio-rng-pci,rng=guix-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?
- (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)))))
-
-(define* (register-closure prefix closure
- #:key
- (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."
- (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
- #:registration-time %epoch)))))
-
-
-;;;
-;;; Partitions.
-;;;
-
-(define-record-type* <partition> partition make-partition
- partition?
- (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 '()))
- (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 25% overhead.
- (round (* 1.25 (closure-size graphs))))
-
-(define* (initialize-partition-table device partitions
- #:key
- (label-type "msdos")
- (offset (expt 2 20)))
- "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)))
- (append-map (lambda (flag)
- (list "set" (number->string index)
- (symbol->string flag) "on"))
- (partition-flags part))))
-
- (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))))))
-
- (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)
- ", "))
- (apply invoke "parted" "--script"
- device "mklabel" label-type
- (options partitions offset))
-
- ;; 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)))
-
-(define MS_BIND 4096) ; <sys/mounts.h> again!
-
-(define* (create-ext-file-system partition type
- #: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"
- 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 (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
- (append (if label `("-n" ,label) '()) options)))
-
-(define* (format-partition partition type
- #:key label uuid (options '()))
- "Create a file system TYPE on PARTITION. If LABEL is true, use that as the
-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
- #:options options))
- ((or (string-prefix? "fat" type) (string= "vfat" type))
- (create-fat-file-system partition #:label label #:uuid uuid
- #:options options))
- (else (error "Unsupported file system."))))
-
-(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)
- #:label (partition-label partition)
- #:uuid (partition-uuid partition)
- #:options (partition-file-system-options partition))
- (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)
- 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 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)))
-
- (when copy-closures?
- ;; Populate the store.
- (populate-store (map (cut string-append "/xchg/" <>) closures)
- target
- #:deduplicate? deduplicate?))
-
- ;; Populate /dev.
- (make-device-nodes target)
-
- ;; Optionally, register the inputs in the image's store.
- (when register-closures?
- (unless copy-closures?
- ;; 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))
-
- (display "registering closures...\n")
- (for-each (lambda (closure)
- (register-closure target
- (string-append "/xchg/" closure)))
- closures)
- (unless copy-closures?
- (umount target-store)))
-
- ;; Add the non-store directories and files.
- (display "populating...\n")
- (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' 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."
- (let ((directory (string-append target "/var/guix/gcroots")))
- (mkdir-p directory)
- (symlink bootcfg (string-append directory "/bootcfg"))))
-
-(define* (initialize-hard-disk device
- #:key
- bootloader-package
- bootcfg
- bootcfg-location
- bootloader-installer
- (grub-efi #f)
- (partitions '()))
- "Initialize DEVICE as a disk containing all the <partition> objects listed
-in PARTITIONS, and using BOOTCFG as its bootloader configuration file.
-
-Each partition is initialized by calling its 'initializer' procedure,
-passing it a directory name where it is mounted."
-
- (define (partition-bootable? partition)
- "Return the first partition found with the boot flag set."
- (member 'boot (partition-flags partition)))
-
- (define (partition-esp? partition)
- "Return the first EFI System Partition."
- (member 'esp (partition-flags partition)))
-
- (let* ((partitions (initialize-partition-table device partitions))
- (root (find partition-bootable? partitions))
- (esp (find partition-esp? partitions))
- (target "/fs"))
- (unless root
- (error "no bootable partition specified" partitions))
-
- (for-each initialize-partition partitions)
-
- (display "mounting root partition...\n")
- (mkdir-p target)
- (mount (partition-device root) target (partition-file-system root))
- (install-boot-config bootcfg bootcfg-location target)
- (when bootloader-installer
- (display "installing bootloader...\n")
- (bootloader-installer bootloader-package device target))
-
- (when esp
- ;; Mount the ESP somewhere and install GRUB UEFI image.
- (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))
-
- (display "creating EFI firmware image...")
- (install-efi-loader grub-efi mount-point)
- (display "done.\n")
-
- (umount mount-point)))
-
- ;; Register BOOTCFG as a GC root.
- (register-bootcfg-root target bootcfg)
-
- (umount target)))
-
-;;; vm.scm ends here
@@ -717,7 +717,6 @@ GNU_SYSTEM_MODULES = \
%D%/build/linux-modules.scm \
%D%/build/marionette.scm \
%D%/build/secret-service.scm \
- %D%/build/vm.scm \
\
%D%/tests.scm \
%D%/tests/audio.scm \
@@ -35,7 +35,7 @@ (define-module (gnu system vm)
#:use-module (guix base32)
#:use-module ((guix self) #:select (make-config.scm))
- #:use-module ((gnu build vm)
+ #:use-module ((gnu build marionette)
#:select (qemu-command))
#:use-module (gnu packages base)
#:use-module (gnu packages bootloaders)
@@ -67,13 +67,8 @@ (define-module (gnu system vm)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
- #:export (expression->derivation-in-linux-vm
- qemu-image
- virtualized-operating-system
-
- system-qemu-image/shared-store
+ #:export (virtualized-operating-system
system-qemu-image/shared-store-script
- system-docker-image
virtual-machine
virtual-machine?))
@@ -126,444 +121,6 @@ (define %linux-vm-file-systems
%default-msize-value))
(check? #f))))
-(define not-config?
- ;; Select (guix …) and (gnu …) modules, except (guix config).
- (match-lambda
- (('guix 'config) #f)
- (('guix rest ...) #t)
- (('gnu rest ...) #t)
- (rest #f)))
-
-(define gcrypt-sqlite3&co
- ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
- (append-map (lambda (package)
- (cons package
- (match (package-transitive-propagated-inputs package)
- (((labels packages) ...)
- packages))))
- (list guile-gcrypt guile-sqlite3)))
-
-(define* (expression->derivation-in-linux-vm name exp
- #:key
- (system (%current-system))
- (linux linux-libre)
- initrd
- (qemu qemu-minimal)
- (env-vars '())
- (guile-for-build
- (%guile-for-build))
- (file-systems
- %linux-vm-file-systems)
-
- (single-file-output? #f)
- (make-disk-image? #f)
- (references-graphs #f)
- (memory-size 256)
- (disk-image-format "qcow2")
- (disk-image-size 'guess)
-
- (substitutable? #t))
- "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
-derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the
-virtual machine, EXP has access to FILE-SYSTEMS, which, by default, includes a
-9p share of the store, the '/xchg' where EXP should put its output file(s),
-and a 9p share of /tmp.
-
-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, then create a QEMU disk image of type
-DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
-return it. When DISK-IMAGE-SIZE is 'guess, estimate the image size based
-based on the size of the closure of REFERENCES-GRAPHS.
-
-When REFERENCES-GRAPHS is true, it must be a list of file name/store path
-pairs, as for `derivation'. The files containing the reference graphs are
-made available under the /xchg CIFS share.
-
-SUBSTITUTABLE? determines whether the returned derivation should be marked as
-substitutable."
- (define user-builder
- (program-file "builder-in-linux-vm" exp))
-
- (define loader
- ;; Invoke USER-BUILDER instead using 'primitive-load'. The reason for
- ;; this is to allow USER-BUILDER to dlopen stuff by using a full-featured
- ;; Guile, which it couldn't do using the statically-linked guile used in
- ;; the initrd. See example at
- ;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>.
- (program-file "linux-vm-loader"
- ;; Communicate USER-BUILDER's exit status via /xchg so that
- ;; the host can distinguish between success, failure, and
- ;; kernel panic.
- #~(let ((status (system* #$user-builder)))
- (call-with-output-file "/xchg/.exit-status"
- (lambda (port)
- (write status port)))
- (sync)
- (reboot))))
-
- (define-syntax-rule (check predicate)
- (let-system (system target)
- (predicate (or target system))))
-
- (let ((initrd (or initrd
- (base-initrd file-systems
- #:on-error 'backtrace
- #:linux linux
- #:linux-modules %base-initrd-modules
- #:qemu-networking? #t))))
-
- (define builder
- ;; Code that launches the VM that evaluates EXP.
- (with-extensions gcrypt-sqlite3&co
- (with-imported-modules `(,@(source-module-closure
- '((guix build utils)
- (gnu build vm))
- #:select? not-config?)
-
- ;; For consumption by (gnu store database).
- ((guix config) => ,(make-config.scm)))
- #~(begin
- (use-modules (guix build utils)
- (gnu build vm))
-
- ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded
- ;; by 'estimated-partition-size' below.
- (setenv "GUIX_LOCPATH"
- #+(file-append glibc-utf8-locales "/lib/locale"))
- (setlocale LC_ALL "en_US.utf8")
-
- (let* ((native-inputs
- '#+(list qemu (canonical-package coreutils)))
- (linux (string-append
- #+linux "/"
- #+(system-linux-image-file-name system)))
- (initrd #+initrd)
- (loader #+loader)
- (graphs '#$(match references-graphs
- (((graph-files . _) ...) graph-files)
- (_ #f)))
- (target #$(let-system (system target)
- (or target system)))
- (size #$(if (eq? 'guess disk-image-size)
- #~(+ (* 70 (expt 2 20)) ;ESP
- (estimated-partition-size graphs))
- disk-image-size)))
-
- (set-path-environment-variable "PATH" '("bin") native-inputs)
-
- (load-in-linux-vm loader
- #:output #$output
- #:linux linux #:initrd initrd
- #:qemu (qemu-command target)
- #:memory-size #$memory-size
- #:make-disk-image? #$make-disk-image?
- #:single-file-output? #$single-file-output?
- #:disk-image-format #$disk-image-format
- #:disk-image-size size
- #:references-graphs graphs))))))
-
- (gexp->derivation name builder
- ;; TODO: Require the "kvm" feature.
- #:system system
- #:target #f ;EXP is always executed natively
- #:env-vars env-vars
- #:guile-for-build guile-for-build
- #:references-graphs references-graphs
- #:substitutable? substitutable?)))
-
-(define (has-guix-service-type? os)
- "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
- (not (not (find (lambda (service)
- (eq? (service-kind service) guix-service-type))
- (operating-system-services os)))))
-
-(define* (qemu-image #:key
- (name "qemu-image")
- (system (%current-system))
- (target (%current-target-system))
- (qemu qemu-minimal)
- (disk-image-size 'guess)
- (disk-image-format "qcow2")
- (file-system-type "ext4")
- (file-system-options '())
- (device-nodes 'linux)
- (extra-directives '())
- file-system-label
- file-system-uuid
- os
- bootcfg-drv
- bootloader
- (register-closures? (has-guix-service-type? os))
- (inputs '())
- copy-inputs?
- (substitutable? #t))
- "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
-'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
-Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
-partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
-partition (a UUID object). FILE-SYSTEM-OPTIONS is an optional list of
-command-line options passed to 'mkfs.ext4' (or similar).
-
-The returned image is a full disk image that runs OS-DERIVATION,
-with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
-file (GRUB-CONFIGURATION must be the name of a file in the VM.)
-
-INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
-all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
-register INPUTS in the store database of the image so that Guix can be used in
-the image. By default, REGISTER-CLOSURES? is set to true only if a service of
-type GUIX-SERVICE-TYPE is present in the services definition of the operating
-system.
-
-When DEVICE-NODES is 'linux, create Linux-device block and character devices
-under /dev. When it is 'hurd, do Hurdish things.
-
-EXTRA-DIRECTIVES is an optional list of directives to populate the root file
-system that is passed to 'populate-root-file-system'."
- (define schema
- (and register-closures?
- (local-file (search-path %load-path
- "guix/store/schema.sql"))))
-
- (define preserve-target
- (if target
- (lambda (obj)
- (with-parameters ((%current-target-system target))
- obj))
- identity))
-
- (define inputs*
- (map (match-lambda
- ((name thing)
- `(,name ,(preserve-target thing)))
- ((name thing output)
- `(,name ,(preserve-target thing) ,output)))
- inputs))
-
- (expression->derivation-in-linux-vm
- name
- (with-extensions gcrypt-sqlite3&co
- (with-imported-modules `(,@(source-module-closure '((gnu build vm)
- (gnu build bootloader)
- (gnu build hurd-boot)
- (guix store database)
- (guix build utils))
- #:select? not-config?)
- ((guix config) => ,(make-config.scm)))
- #~(begin
- (use-modules (gnu build bootloader)
- (gnu build vm)
- ((gnu build hurd-boot)
- #:select (make-hurd-device-nodes))
- ((gnu build linux-boot)
- #:select (make-essential-device-nodes))
- (guix store database)
- (guix build utils)
- (srfi srfi-26)
- (ice-9 binary-ports))
-
- (sql-schema #$schema)
-
- ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
- (setenv "GUIX_LOCPATH"
- #+(file-append glibc-utf8-locales "/lib/locale"))
- (setlocale LC_ALL "en_US.utf8")
-
- (let ((inputs
- '#+(append (list parted e2fsprogs dosfstools)
- (map canonical-package
- (list sed grep coreutils findutils gawk))))
-
- ;; This variable is unused but allows us to add INPUTS-TO-COPY
- ;; as inputs.
- (to-register
- '#$(map (match-lambda
- ((name thing) thing)
- ((name thing output) `(,thing ,output)))
- inputs*)))
-
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
-
- (let* ((graphs '#$(match inputs
- (((names . _) ...)
- names)))
- (initialize (root-partition-initializer
- #:extra-directives '#$extra-directives
- #:closures graphs
- #:copy-closures? #$copy-inputs?
- #:register-closures? #$register-closures?
- #:system-directory #$(preserve-target os)
-
- #:make-device-nodes
- #$(match device-nodes
- ('linux #~make-essential-device-nodes)
- ('hurd #~make-hurd-device-nodes))
-
- ;; Disable deduplication to speed things up,
- ;; and because it doesn't help much for a
- ;; single system generation.
- #:deduplicate? #f))
- (root-size #$(if (eq? 'guess disk-image-size)
- #~(max
- ;; Minimum 20 MiB root size
- (* 20 (expt 2 20))
- (estimated-partition-size
- (map (cut string-append "/xchg/" <>)
- graphs)))
- (- disk-image-size
- (* 50 (expt 2 20)))))
- (partitions
- (append
- (list (partition
- (size root-size)
- (label #$file-system-label)
- (uuid #$(and=> file-system-uuid
- uuid-bytevector))
- (file-system #$file-system-type)
- (file-system-options '#$file-system-options)
- (flags '(boot))
- (initializer initialize)))
- ;; Append a small EFI System Partition for use with UEFI
- ;; bootloaders if we are not targeting ARM because UEFI
- ;; support in U-Boot is experimental.
- ;;
- ;; FIXME: ‘target-arm?’ may be not operate on the right
- ;; system/target values. Rewrite using ‘let-system’ when
- ;; available.
- (if #$(target-arm?)
- '()
- (list (partition
- ;; The standalone grub image is about 10MiB, but
- ;; leave some room for custom or multiple images.
- (size (* 40 (expt 2 20)))
- (label "GNU-ESP") ;cosmetic only
- ;; Use "vfat" here since this property is used
- ;; when mounting. The actual FAT-ness is based
- ;; on file system size (16 in this case).
- (file-system "vfat")
- (flags '(esp)))))))
- (grub-efi #$(and (not (target-arm?)) grub-efi)))
- (initialize-hard-disk "/dev/vda"
- #:partitions partitions
- #:grub-efi grub-efi
- #:bootloader-package
- #+(bootloader-package bootloader)
- #:bootcfg #$(preserve-target bootcfg-drv)
- #:bootcfg-location
- #$(bootloader-configuration-file bootloader)
- #:bootloader-installer
- #+(bootloader-installer bootloader)))))))
- #:system system
- #:make-disk-image? #t
- #:disk-image-size disk-image-size
- #:disk-image-format disk-image-format
- #:references-graphs inputs*
- #:substitutable? substitutable?))
-
-(define* (system-docker-image os
- #:key
- (name "guix-docker-image")
- (memory-size 256)
- (register-closures? (has-guix-service-type? os))
- shared-network?)
- "Build a docker image. OS is the desired <operating-system>. NAME is the
-base name to use for the output file. When SHARED-NETWORK? is true, assume
-that the container will share network with the host and thus doesn't need a
-DHCP client, nscd, and so on.
-
-When REGISTER-CLOSURES? is true, register the closure of OS with Guix in the
-resulting Docker image. By default, REGISTER-CLOSURES? is set to true only if
-a service of type GUIX-SERVICE-TYPE is present in the services definition of
-the operating system."
- (define schema
- (and register-closures?
- (local-file (search-path %load-path
- "guix/store/schema.sql"))))
-
- (define boot-program
- ;; Program that runs the boot script of OS, which in turn starts shepherd.
- (program-file "boot-program"
- #~(let ((system (cadr (command-line))))
- (setenv "GUIX_NEW_SYSTEM" system)
- (execl #$(file-append guile-3.0 "/bin/guile")
- "guile" "--no-auto-compile"
- (string-append system "/boot")))))
-
-
- (let ((os (operating-system-with-gc-roots
- (containerized-operating-system os '()
- #:shared-network?
- shared-network?)
- (list boot-program)))
- (name (string-append name ".tar.gz"))
- (graph "system-graph"))
- (define build
- (with-extensions (cons guile-json-3 ;for (guix docker)
- gcrypt-sqlite3&co) ;for (guix store database)
- (with-imported-modules `(,@(source-module-closure
- '((guix docker)
- (guix store database)
- (guix build utils)
- (guix build store-copy)
- (gnu build vm))
- #:select? not-config?)
- ((guix config) => ,(make-config.scm)))
- #~(begin
- (use-modules (guix docker)
- (guix build utils)
- (gnu build vm)
- (srfi srfi-19)
- (guix build store-copy)
- (guix store database))
-
- ;; Set the SQL schema location.
- (sql-schema #$schema)
-
- ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
- (setenv "GUIX_LOCPATH"
- #+(file-append glibc-utf8-locales "/lib/locale"))
- (setlocale LC_ALL "en_US.utf8")
-
- (let* (;; This initializer requires elevated privileges that are
- ;; not normally available in the build environment (e.g.,
- ;; it needs to create device nodes). In order to obtain
- ;; such privileges, we run it as root in a VM.
- (initialize (root-partition-initializer
- #:closures '(#$graph)
- #:register-closures? #$register-closures?
- #:system-directory #$os
- ;; De-duplication would fail due to
- ;; cross-device link errors, so don't do it.
- #:deduplicate? #f))
- ;; Even as root in a VM, the initializer would fail due to
- ;; lack of privileges if we use a root-directory that is on
- ;; a file system that is shared with the host (e.g., /tmp).
- (root-directory "/guix-system-root"))
- (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
- (mkdir root-directory)
- (initialize root-directory)
- (build-docker-image
- (string-append "/xchg/" #$name) ;; The output file.
- (cons* root-directory
- (map store-info-item
- (call-with-input-file
- (string-append "/xchg/" #$graph)
- read-reference-graph)))
- #$os
- #:entry-point '(#$boot-program #$os)
- #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
- #:creation-time (make-time time-utc 0 1)
- #:transformations `((,root-directory -> ""))))))))
-
- (expression->derivation-in-linux-vm
- name build
- #:memory-size memory-size
- #:make-disk-image? #f
- #:single-file-output? #t
- #:references-graphs `((,graph ,os)))))
-
;;;
;;; VMs that share file systems with the host.
@@ -655,46 +212,6 @@ (define virtual-file-systems
(needed-for-boot? #t))
virtual-file-systems)))))
-(define* (system-qemu-image/shared-store
- os
- #:key
- (system (%current-system))
- (target (%current-target-system))
- full-boot?
- (disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
- "Return a derivation that builds a QEMU image of OS that shares its store
-with the host.
-
-When FULL-BOOT? is true, return an image that does a complete boot sequence,
-bootloaded included; thus, make a disk image that contains everything the
-bootloader refers to: OS kernel, initrd, bootloader data, etc."
- (define root-uuid
- ;; Use a fixed UUID to improve determinism.
- (operating-system-uuid os 'dce))
-
- (define bootcfg
- (operating-system-bootcfg os))
-
- ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains
- ;; BOOTCFG and all its dependencies, including the output of OS.
- ;; This is more than needed (we only need the kernel, initrd, GRUB for its
- ;; font, and the background image), but it's hard to filter that.
- (qemu-image #:os os
- #:system system
- #:target target
- #:bootcfg-drv bootcfg
- #:bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os))
- #:disk-image-size disk-image-size
- #:file-system-uuid root-uuid
- #:inputs (if full-boot?
- `(("bootcfg" ,bootcfg))
- '())
-
- ;; XXX: Passing #t here is too slow, so let it off by default.
- #:register-closures? #f
- #:copy-inputs? full-boot?))
-
(define* (common-qemu-options image shared-fs
#:key rw-image?)
"Return the a string-value gexp with the common QEMU options to boot IMAGE,
@@ -31,7 +31,7 @@ (define-module (gnu tests install)
#:use-module (gnu system image)
#:use-module (gnu system install)
#:use-module (gnu system vm)
- #:use-module ((gnu build vm) #:select (qemu-command))
+ #:use-module ((gnu build marionette) #:select (qemu-command))
#:use-module (gnu packages admin)
#:use-module (gnu packages bootloaders)
#:use-module (gnu packages commencement) ;for 'guile-final'
@@ -39,10 +39,10 @@ (define-module (test-modules)
(live-module-closure '((gnu build install)))
(source-module-closure '((gnu build install)))))
-(test-assert "closure of (gnu build vm)"
+(test-assert "closure of (gnu build image)"
(lset= equal?
- (live-module-closure '((gnu build vm)))
- (source-module-closure '((gnu build vm)))))
+ (live-module-closure '((gnu build image)))
+ (source-module-closure '((gnu build image)))))
(test-equal "&missing-dependency-error"
'(something that does not exist)