diff options
| -rw-r--r-- | doc/guix.texi | 4 | ||||
| -rw-r--r-- | gnu/build/marionette.scm | 14 | ||||
| -rw-r--r-- | gnu/build/vm.scm | 500 | ||||
| -rw-r--r-- | gnu/local.mk | 1 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 487 | ||||
| -rw-r--r-- | gnu/tests/install.scm | 2 | ||||
| -rw-r--r-- | tests/modules.scm | 6 |
7 files changed, 21 insertions, 993 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index 72a0b09d3e..c40d153466 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10174,11 +10174,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 diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm index 0ebe535526..b336024610 100644 --- a/gnu/build/marionette.scm +++ b/gnu/build/marionette.scm @@ -24,6 +24,7 @@ #: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 @@ %qwerty-us-keystrokes marionette-type - system-test-runner)) + system-test-runner + qemu-command)) ;;; Commentary: ;;; @@ -426,4 +428,14 @@ LOG-DIRECTORY is specified, create log file within it." (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 diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm deleted file mode 100644 index 9d32824764..0000000000 --- a/gnu/build/vm.scm +++ /dev/null @@ -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 diff --git a/gnu/local.mk b/gnu/local.mk index 72fa405e17..0f7eddc864 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -718,7 +718,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 \ diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index db5c4132c0..3370df1c81 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -35,7 +35,7 @@ #: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 @@ #: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 @@ %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 @@ environment with the store shared with the host. MAPPINGS is a list of (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, diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 9602efebe7..154f98b2e1 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -31,7 +31,7 @@ #: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' diff --git a/tests/modules.scm b/tests/modules.scm index 57019c600c..e70d2d9e08 100644 --- a/tests/modules.scm +++ b/tests/modules.scm @@ -39,10 +39,10 @@ (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) |