@@ -22,7 +22,7 @@
@set SUBSTITUTE-URLS https://@value{SUBSTITUTE-SERVER-1} https://@value{SUBSTITUTE-SERVER-2}
@copying
-Copyright @copyright{} 2012-2023 Ludovic Courtès@*
+Copyright @copyright{} 2012-2024 Ludovic Courtès@*
Copyright @copyright{} 2013, 2014, 2016 Andreas Enge@*
Copyright @copyright{} 2013 Nikita Karetnikov@*
Copyright @copyright{} 2014, 2015, 2016 Alex Kost@*
@@ -1297,6 +1297,11 @@ Build Environment Setup
@file{/homeless-shelter}. This helps to highlight inappropriate uses of
@env{HOME} in the build scripts of packages.
+All this usually enough to ensure details of the environment do not
+influence build processes. In some exceptional cases where more control
+is needed---typically over the date, kernel, or CPU---you can resort to
+a virtual build machine (@pxref{build-vm, virtual build machines}).
+
You can influence the directory where the daemon stores build trees
@i{via} the @env{TMPDIR} environment variable. However, the build tree
within the chroot is always called @file{/tmp/guix-build-@var{name}.drv-0},
@@ -36081,6 +36086,138 @@ Virtualization Services
@end deftp
+@anchor{build-vm}
+@subsubheading Virtual Build Machines
+
+@cindex virtual build machines
+@cindex build VMs
+@cindex VMs, for offloading
+@dfn{Virtual build machines} or ``build VMs'' let you offload builds to
+a fully controlled environment. ``How can it be more controlled than
+regular builds? And why would it be useful?'', you ask. Good
+questions.
+
+Builds spawned by @code{guix-daemon} indeed run in a controlled
+environment; specifically the daemon spawns build processes in separate
+namespaces and in a chroot, such as that build processes only see their
+declared dependencies and a well-defined subset of the file system tree
+(@pxref{Build Environment Setup}, for details). A few aspects of the
+environments are not controlled though: the operating system kernel, the
+CPU model, and the date. Most of the time, these aspects have no impact
+on the build process: the level of isolation @code{guix-daemon} provides
+is ``good enough''.
+
+@cindex time traps
+However, there are occasionally cases where those aspects @emph{do}
+influence the build process. A typical example is @dfn{time traps}:
+build processes that stop working after a certain date@footnote{The most
+widespread example of time traps is test suites that involve checking
+the expiration date of a certificate. Such tests exists in TLS
+implementations such as OpenSSL and GnuTLS, but also in high-level
+software such as Python.}. Another one is software that optimizes for
+the CPU microarchitecture it is built on or, worse, bugs that manifest
+only on specific CPUs.
+
+To address that, @code{virtual-build-machine-service-type} lets you add
+a virtual build machine on your system, as in this example:
+
+@lisp
+(use-modules (gnu services virtualization))
+
+(operating-system
+ ;; @dots{}
+ (services (append (list (service virtual-build-machine-service-type))
+ %base-services)))
+@end lisp
+
+By default, you have to explicitly start the build machine when you need
+it, at which point builds may be offloaded to it (@pxref{Daemon Offload
+Setup}):
+
+@example
+herd start build-vm
+@end example
+
+With the default setting shown above, the build VM runs with its clock
+set to a date several years in the past, and on a CPU model that
+corresponds to that date---a model possibly older than that of your
+machine. This lets you rebuild today software from the past that would
+otherwise fail to build due to a time trap or other issues in its build
+process.
+
+You can configure the build VM, as in this example:
+
+@lisp
+(service virtual-build-machine-service-type
+ (virtual-build-machine
+ (cpu "Westmere")
+ (cpu-count 8)
+ (memory-size (* 1 1024))
+ (auto-start? #t)))
+@end lisp
+
+The available options are shown below.
+
+@defvar virtual-build-machine-service-type
+This is the service type to run @dfn{virtual build machines}. Virtual
+build machines are configured so that builds are offloaded to them when
+they are running.
+@end defvar
+
+@deftp {Data Type} virtual-build-machine
+This is the data type specifying the configuration of a build machine.
+It contains the fields below:
+
+@table @asis
+@item @code{name} (default: @code{'build-vm})
+The name of this build VM. It is used to construct the name of its
+Shepherd service.
+
+@item @code{image}
+The image of the virtual machine (@pxref{System Images}). This notably
+specifies the virtual disk size and the operating system running into it
+(@pxref{operating-system Reference}). The default value is a minimal
+operating system image.
+
+@item @code{qemu} (default: @code{qemu-minimal})
+The QEMU package to run the image.
+
+@item @code{cpu}
+The CPU model being emulated as a string denoting a model known to QEMU.
+
+The default value is a model that matches @code{date} (see below). To
+see what CPU models are available, run, for example:
+
+@example
+qemu-system-x86_64 -cpu help
+@end example
+
+@item @code{cpu-count} (default: @code{4})
+The number of CPUs emulated by the virtual machine.
+
+@item @code{memory-size} (default: @code{2048})
+Size in mebibytes (MiB) of the virtual machine's main memory (RAM).
+
+@item @code{date} (default: a few years ago)
+Date inside the virtual machine when it starts; this must be a SRFI-19
+date object (@pxref{SRFI-19 Date,,, guile, GNU Guile Reference Manual}).
+
+@item @code{port-forwardings} (default: 11022 and 11004)
+TCP ports of the virtual machine forwarded to the host. By default, the
+SSH and secrets ports are forwarded into the host.
+
+@item @code{systems} (default: @code{(list (%current-system))})
+List of system types supported by the build VM---e.g.,
+@code{"x86_64-linux"}.
+
+@item @code{auto-start?} (default: @code{#f})
+Whether to start the virtual machine when the system boots.
+@end table
+@end deftp
+
+In the next section, you'll find a variant on this theme: GNU/Hurd
+virtual machines!
+
@anchor{hurd-vm}
@subsubheading The Hurd in a Virtual Machine
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.com>
-;;; Copyright © 2018, 2020-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2020-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020, 2021, 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2021 Timotej Lazar <timotej.lazar@araneo.si>
;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com>
@@ -43,6 +43,8 @@ (define-module (gnu services virtualization)
#:use-module (gnu system hurd)
#:use-module (gnu system image)
#:use-module (gnu system shadow)
+ #:autoload (gnu system vm) (linux-image-startup-command
+ virtualized-operating-system)
#:use-module (gnu system)
#:use-module (guix derivations)
#:use-module (guix gexp)
@@ -55,12 +57,20 @@ (define-module (gnu services virtualization)
#:autoload (guix self) (make-config.scm)
#:autoload (guix platform) (platform-system)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
- #:export (%hurd-vm-operating-system
+ #:export (virtual-build-machine
+ virtual-build-machine-service-type
+
+ %virtual-build-machine-operating-system
+ %virtual-build-machine-default-vm
+
+ %hurd-vm-operating-system
hurd-vm-configuration
hurd-vm-configuration?
hurd-vm-configuration-os
@@ -1064,6 +1074,459 @@ (define* (secret-service-operating-system os
(inherit config)
(generate-substitute-key? #f))))))))
+
+;;;
+;;; Offloading-as-a-service.
+;;;
+
+(define-record-type* <virtual-build-machine>
+ virtual-build-machine make-virtual-build-machine
+ virtual-build-machine?
+ this-virtual-build-machine
+ (name virtual-build-machine-name
+ (default 'build-vm))
+ (image virtual-build-machine-image
+ (thunked)
+ (default
+ (virtual-build-machine-default-image
+ this-virtual-build-machine)))
+ (qemu virtual-build-machine-qemu
+ (default qemu-minimal))
+ (cpu virtual-build-machine-cpu
+ (thunked)
+ (default
+ (qemu-cpu-model-for-date
+ (virtual-build-machine-systems this-virtual-build-machine)
+ (virtual-build-machine-date this-virtual-build-machine))))
+ (cpu-count virtual-build-machine-cpu-count
+ (default 4))
+ (memory-size virtual-build-machine-memory-size ;integer (MiB)
+ (default 2048))
+ (date virtual-build-machine-date
+ (default (make-date 0 0 00 00 01 01 2020 0)))
+ (port-forwardings virtual-build-machine-port-forwardings
+ (default
+ `((,%build-vm-ssh-port . 22)
+ (,%build-vm-secrets-port . 1004))))
+ (systems virtual-build-machine-systems
+ (default (list (%current-system))))
+ (auto-start? virtual-build-machine-auto-start?
+ (default #f)))
+
+(define %build-vm-ssh-port
+ ;; Default host port where the guest's SSH port is forwarded.
+ 11022)
+
+(define %build-vm-secrets-port
+ ;; Host port to communicate secrets to the build VM.
+ ;; FIXME: Anyone on the host can talk to it; use virtio ports or AF_VSOCK
+ ;; instead.
+ 11044)
+
+(define %x86-64-intel-cpu-models
+ ;; List of release date/CPU model pairs representing Intel's x86_64 models.
+ ;; The list is taken from
+ ;; <https://en.wikipedia.org/wiki/List_of_Intel_CPU_microarchitectures>.
+ ;; CPU model strings are those found in 'qemu-system-x86_64 -cpu help'.
+ (letrec-syntax ((cpu-models (syntax-rules ()
+ ((_ (date model) rest ...)
+ (alist-cons (date->time-utc
+ (string->date date "~Y-~m-~d"))
+ model
+ (cpu-models rest ...)))
+ ((_)
+ '()))))
+ (reverse
+ (cpu-models ("2006-01-01" "core2duo")
+ ("2010-01-01" "Westmere")
+ ("2008-01-01" "Nehalem")
+ ("2011-01-01" "SandyBridge")
+ ("2012-01-01" "IvyBridge")
+ ("2013-01-01" "Haswell")
+ ("2014-01-01" "Broadwell")
+ ("2015-01-01" "Skylake-Client")))))
+
+(define (qemu-cpu-model-for-date systems date)
+ "Return the QEMU name of a CPU model for SYSTEMS that was current at DATE."
+ (if (any (cut string-prefix? "x86_64-" <>) systems)
+ (let ((time (date->time-utc date)))
+ (any (match-lambda
+ ((release-date . model)
+ (and (time<? release-date time)
+ model)))
+ %x86-64-intel-cpu-models))
+ ;; TODO: Add models for other architectures.
+ "host"))
+
+(define (virtual-build-machine-ssh-port config)
+ "Return the host port where CONFIG has its VM's SSH port forwarded."
+ (any (match-lambda
+ ((host-port . 22) host-port)
+ (_ #f))
+ (virtual-build-machine-port-forwardings config)))
+
+(define (virtual-build-machine-secrets-port config)
+ "Return the host port where CONFIG has its VM's secrets port forwarded."
+ (any (match-lambda
+ ((host-port . 1004) host-port)
+ (_ #f))
+ (virtual-build-machine-port-forwardings config)))
+
+(define %minimal-vm-syslog-config
+ ;; Minimal syslog configuration for a VM.
+ (plain-file "vm-syslog.conf" "\
+# Log most messages to the console, which goes to the serial
+# output, allowing the host to log it.
+*.info;auth.notice;authpriv.none -/dev/console
+
+# The rest.
+*.=debug -/var/log/debug
+authpriv.*;auth.info /var/log/secure
+"))
+
+(define %virtual-build-machine-operating-system
+ (operating-system
+ (host-name "build-machine")
+ (bootloader (bootloader-configuration ;unused
+ (bootloader grub-minimal-bootloader)
+ (targets '("/dev/null"))))
+ (file-systems (list (file-system ;unused
+ (mount-point "/")
+ (device "none")
+ (type "tmpfs"))))
+ (users (cons (user-account
+ (name "offload")
+ (group "users")
+ (supplementary-groups '("kvm"))
+ (comment "Account used for offloading"))
+ %base-user-accounts))
+ (services (cons* (service static-networking-service-type
+ (list %qemu-static-networking))
+ (service openssh-service-type
+ (openssh-configuration
+ (openssh openssh-sans-x)))
+
+ (modify-services %base-services
+ ;; By default, the secret service introduces a
+ ;; pre-initialized /etc/guix/acl file in the VM. Thus,
+ ;; clear 'authorize-key?' so that it's not overridden
+ ;; at activation time.
+ (guix-service-type config =>
+ (guix-configuration
+ (inherit config)
+ (authorize-key? #f)))
+ (syslog-service-type config =>
+ (syslog-configuration
+ (config-file
+ %minimal-vm-syslog-config)))
+ (delete mingetty-service-type)
+ (delete console-font-service-type))))))
+
+(define (virtual-build-machine-default-image config)
+ (let* ((type (lookup-image-type-by-name 'mbr-raw))
+ (base (os->image %virtual-build-machine-operating-system
+ #:type type)))
+ (image (inherit base)
+ (name (symbol-append 'build-vm-
+ (virtual-build-machine-name config)))
+ (format 'compressed-qcow2)
+ (partition-table-type 'mbr)
+ (shared-store? #f)
+ (size (* 10 (expt 2 30))))))
+
+(define (virtual-build-machine-account-name config)
+ (string-append "build-vm-"
+ (symbol->string
+ (virtual-build-machine-name config))))
+
+(define (virtual-build-machine-accounts config)
+ (let ((name (virtual-build-machine-account-name config)))
+ (list (user-group (name name) (system? #t))
+ (user-account
+ (name name)
+ (group name)
+ (supplementary-groups '("kvm"))
+ (comment "Privilege separation user for the virtual build machine")
+ (home-directory "/var/empty")
+ (shell (file-append shadow "/sbin/nologin"))
+ (system? #t)))))
+
+(define (build-vm-shepherd-services config)
+ (define transform
+ (compose secret-service-operating-system
+ operating-system-with-locked-root-account
+ operating-system-with-offloading-account
+ (lambda (os)
+ (virtualized-operating-system os #:full-boot? #t))))
+
+ (define transformed-image
+ (let ((base (virtual-build-machine-image config)))
+ (image
+ (inherit base)
+ (operating-system
+ (transform (image-operating-system base))))))
+
+ (define command
+ (linux-image-startup-command transformed-image
+ #:qemu
+ (virtual-build-machine-qemu config)
+ #:cpu
+ (virtual-build-machine-cpu config)
+ #:cpu-count
+ (virtual-build-machine-cpu-count config)
+ #:memory-size
+ (virtual-build-machine-memory-size config)
+ #:port-forwardings
+ (virtual-build-machine-port-forwardings
+ config)
+ #:date
+ (virtual-build-machine-date config)))
+
+ (define user
+ (virtual-build-machine-account-name config))
+
+ (list (shepherd-service
+ (documentation "Run the build virtual machine service.")
+ (provision (list (virtual-build-machine-name config)))
+ (requirement '(user-processes))
+ (modules `((gnu build secret-service)
+ (guix build utils)
+ ,@%default-modules))
+ (start
+ (with-imported-modules (source-module-closure
+ '((gnu build secret-service)
+ (guix build utils)))
+ #~(lambda arguments
+ (let* ((pid (fork+exec-command (append #$command arguments)
+ #:user #$user
+ #:group "kvm"
+ #:environment-variables
+ ;; QEMU tries to write to /var/tmp
+ ;; by default.
+ '("TMPDIR=/tmp")))
+ (port #$(virtual-build-machine-secrets-port config))
+ (root #$(virtual-build-machine-secret-root config))
+ (address (make-socket-address AF_INET INADDR_LOOPBACK
+ port)))
+ (catch #t
+ (lambda _
+ (if (secret-service-send-secrets address root)
+ pid
+ (begin
+ (kill (- pid) SIGTERM)
+ #f)))
+ (lambda (key . args)
+ (kill (- pid) SIGTERM)
+ (apply throw key args)))))))
+ (stop #~(make-kill-destructor))
+ (auto-start? (virtual-build-machine-auto-start? config)))))
+
+(define (authorize-guest-substitutes-on-host)
+ "Return a program that authorizes the guest's archive signing key (passed as
+an argument) on the host."
+ (define not-config?
+ (match-lambda
+ ('(guix config) #f)
+ (('guix _ ...) #t)
+ (('gnu _ ...) #t)
+ (_ #f)))
+
+ (define run
+ (with-extensions (list guile-gcrypt)
+ (with-imported-modules `(((guix config) => ,(make-config.scm))
+ ,@(source-module-closure
+ '((guix pki)
+ (guix build utils))
+ #:select? not-config?))
+ #~(begin
+ (use-modules (ice-9 match)
+ (ice-9 textual-ports)
+ (gcrypt pk-crypto)
+ (guix pki)
+ (guix build utils))
+
+ (match (command-line)
+ ((_ guest-config-directory)
+ (let ((guest-key (string-append guest-config-directory
+ "/signing-key.pub")))
+ (if (file-exists? guest-key)
+ ;; Add guest key to the host's ACL.
+ (let* ((key (string->canonical-sexp
+ (call-with-input-file guest-key
+ get-string-all)))
+ (acl (public-keys->acl
+ (cons key (acl->public-keys (current-acl))))))
+ (with-atomic-file-replacement %acl-file
+ (lambda (_ port)
+ (write-acl acl port))))
+ (format (current-error-port)
+ "warning: guest key missing from '~a'~%"
+ guest-key)))))))))
+
+ (program-file "authorize-guest-substitutes-on-host" run))
+
+(define (initialize-build-vm-substitutes)
+ "Initialize the Hurd VM's key pair and ACL and store it on the host."
+ (define run
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 match))
+
+ (define host-key
+ "/etc/guix/signing-key.pub")
+
+ (define host-acl
+ "/etc/guix/acl")
+
+ (match (command-line)
+ ((_ guest-config-directory)
+ (setenv "GUIX_CONFIGURATION_DIRECTORY"
+ guest-config-directory)
+ (invoke #+(file-append guix "/bin/guix") "archive"
+ "--generate-key")
+
+ (when (file-exists? host-acl)
+ ;; Copy the host ACL.
+ (copy-file host-acl
+ (string-append guest-config-directory
+ "/acl")))
+
+ (when (file-exists? host-key)
+ ;; Add the host key to the childhurd's ACL.
+ (let ((key (open-fdes host-key O_RDONLY)))
+ (close-fdes 0)
+ (dup2 key 0)
+ (execl #+(file-append guix "/bin/guix")
+ "guix" "archive" "--authorize"))))))))
+
+ (program-file "initialize-build-vm-substitutes" run))
+
+(define* (build-vm-activation secret-directory
+ #:key
+ offloading-ssh-key
+ (offloading? #t))
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+
+ (define secret-directory
+ #$secret-directory)
+
+ (define ssh-directory
+ (string-append secret-directory "/etc/ssh"))
+
+ (define guix-directory
+ (string-append secret-directory "/etc/guix"))
+
+ (define offloading-ssh-key
+ #$offloading-ssh-key)
+
+ (unless (file-exists? ssh-directory)
+ ;; Generate SSH host keys under SSH-DIRECTORY.
+ (mkdir-p ssh-directory)
+ (invoke #$(file-append openssh "/bin/ssh-keygen")
+ "-A" "-f" secret-directory))
+
+ (unless (or (not #$offloading?)
+ (file-exists? offloading-ssh-key))
+ ;; Generate a user SSH key pair for the host to use when offloading
+ ;; to the guest.
+ (mkdir-p (dirname offloading-ssh-key))
+ (invoke #$(file-append openssh "/bin/ssh-keygen")
+ "-t" "ed25519" "-N" ""
+ "-f" offloading-ssh-key)
+
+ ;; Authorize it in the guest for user 'offloading'.
+ (let ((authorizations
+ (string-append ssh-directory
+ "/authorized_keys.d/offloading")))
+ (mkdir-p (dirname authorizations))
+ (copy-file (string-append offloading-ssh-key ".pub")
+ authorizations)
+ (chmod (dirname authorizations) #o555)))
+
+ (unless (file-exists? guix-directory)
+ (invoke #$(initialize-build-vm-substitutes)
+ guix-directory))
+
+ (when #$offloading?
+ ;; Authorize the archive signing key from GUIX-DIRECTORY in the host.
+ (invoke #$(authorize-guest-substitutes-on-host) guix-directory)))))
+
+(define (virtual-build-machine-offloading-ssh-key config)
+ "Return the name of the file containing the SSH key of user 'offloading'."
+ (string-append "/etc/guix/offload/ssh/virtual-build-machine/"
+ (symbol->string
+ (virtual-build-machine-name config))))
+
+(define (virtual-build-machine-activation config)
+ "Return a gexp to activate the build VM according to CONFIG."
+ (build-vm-activation (virtual-build-machine-secret-root config)
+ #:offloading? #t
+ #:offloading-ssh-key
+ (virtual-build-machine-offloading-ssh-key config)))
+
+(define (virtual-build-machine-secret-root config)
+ (string-append "/etc/guix/virtual-build-machines/"
+ (symbol->string
+ (virtual-build-machine-name config))))
+
+(define (check-vm-availability config)
+ "Return a Scheme file that evaluates to true if the service corresponding to
+CONFIG, a <virtual-build-machine>, is up and running."
+ (define service-name
+ (virtual-build-machine-name config))
+
+ (scheme-file "check-build-vm-availability.scm"
+ #~(begin
+ (use-modules (gnu services herd)
+ (srfi srfi-34))
+
+ (guard (c ((service-not-found-error? c) #f))
+ (->bool (current-service '#$service-name))))))
+
+(define (build-vm-guix-extension config)
+ (define vm-ssh-key
+ (string-append
+ (virtual-build-machine-secret-root config)
+ "/etc/ssh/ssh_host_ed25519_key.pub"))
+
+ (define host-ssh-key
+ (virtual-build-machine-offloading-ssh-key config))
+
+ (guix-extension
+ (build-machines
+ (list #~(if (primitive-load #$(check-vm-availability config))
+ (list (build-machine
+ (name "localhost")
+ (port #$(virtual-build-machine-ssh-port config))
+ (systems
+ '#$(virtual-build-machine-systems config))
+ (user "offloading")
+ (host-key (call-with-input-file #$vm-ssh-key
+ (@ (ice-9 textual-ports)
+ get-string-all)))
+ (private-key #$host-ssh-key)))
+ '())))))
+
+(define virtual-build-machine-service-type
+ (service-type
+ (name 'build-vm)
+ (extensions (list (service-extension shepherd-root-service-type
+ build-vm-shepherd-services)
+ (service-extension guix-service-type
+ build-vm-guix-extension)
+ (service-extension account-service-type
+ virtual-build-machine-accounts)
+ (service-extension activation-service-type
+ virtual-build-machine-activation)))
+ (description
+ "Create a @dfn{virtual build machine}: a virtual machine (VM) that builds
+can be offloaded to. By default, the virtual machine starts with a clock
+running at some point in the past.")
+ (default-value (virtual-build-machine))))
+
;;;
;;; The Hurd in VM service: a Childhurd.
@@ -1290,136 +1753,13 @@ (define %hurd-vm-accounts
(shell (file-append shadow "/sbin/nologin"))
(system? #t))))
-(define (initialize-hurd-vm-substitutes)
- "Initialize the Hurd VM's key pair and ACL and store it on the host."
- (define run
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (ice-9 match))
-
- (define host-key
- "/etc/guix/signing-key.pub")
-
- (define host-acl
- "/etc/guix/acl")
-
- (match (command-line)
- ((_ guest-config-directory)
- (setenv "GUIX_CONFIGURATION_DIRECTORY"
- guest-config-directory)
- (invoke #+(file-append guix "/bin/guix") "archive"
- "--generate-key")
-
- (when (file-exists? host-acl)
- ;; Copy the host ACL.
- (copy-file host-acl
- (string-append guest-config-directory
- "/acl")))
-
- (when (file-exists? host-key)
- ;; Add the host key to the childhurd's ACL.
- (let ((key (open-fdes host-key O_RDONLY)))
- (close-fdes 0)
- (dup2 key 0)
- (execl #+(file-append guix "/bin/guix")
- "guix" "archive" "--authorize"))))))))
-
- (program-file "initialize-hurd-vm-substitutes" run))
-
-(define (authorize-guest-substitutes-on-host)
- "Return a program that authorizes the guest's archive signing key (passed as
-an argument) on the host."
- (define not-config?
- (match-lambda
- ('(guix config) #f)
- (('guix _ ...) #t)
- (('gnu _ ...) #t)
- (_ #f)))
-
- (define run
- (with-extensions (list guile-gcrypt)
- (with-imported-modules `(((guix config) => ,(make-config.scm))
- ,@(source-module-closure
- '((guix pki)
- (guix build utils))
- #:select? not-config?))
- #~(begin
- (use-modules (ice-9 match)
- (ice-9 textual-ports)
- (gcrypt pk-crypto)
- (guix pki)
- (guix build utils))
-
- (match (command-line)
- ((_ guest-config-directory)
- (let ((guest-key (string-append guest-config-directory
- "/signing-key.pub")))
- (if (file-exists? guest-key)
- ;; Add guest key to the host's ACL.
- (let* ((key (string->canonical-sexp
- (call-with-input-file guest-key
- get-string-all)))
- (acl (public-keys->acl
- (cons key (acl->public-keys (current-acl))))))
- (with-atomic-file-replacement %acl-file
- (lambda (_ port)
- (write-acl acl port))))
- (format (current-error-port)
- "warning: guest key missing from '~a'~%"
- guest-key)))))))))
-
- (program-file "authorize-guest-substitutes-on-host" run))
-
(define (hurd-vm-activation config)
"Return a gexp to activate the Hurd VM according to CONFIG."
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
-
- (define secret-directory
- #$(hurd-vm-configuration-secret-root config))
-
- (define ssh-directory
- (string-append secret-directory "/etc/ssh"))
-
- (define guix-directory
- (string-append secret-directory "/etc/guix"))
-
- (define offloading-ssh-key
- #$(hurd-vm-configuration-offloading-ssh-key config))
-
- (unless (file-exists? ssh-directory)
- ;; Generate SSH host keys under SSH-DIRECTORY.
- (mkdir-p ssh-directory)
- (invoke #$(file-append openssh "/bin/ssh-keygen")
- "-A" "-f" secret-directory))
-
- (unless (or (not #$(hurd-vm-configuration-offloading? config))
- (file-exists? offloading-ssh-key))
- ;; Generate a user SSH key pair for the host to use when offloading
- ;; to the guest.
- (mkdir-p (dirname offloading-ssh-key))
- (invoke #$(file-append openssh "/bin/ssh-keygen")
- "-t" "ed25519" "-N" ""
- "-f" offloading-ssh-key)
-
- ;; Authorize it in the guest for user 'offloading'.
- (let ((authorizations
- (string-append ssh-directory
- "/authorized_keys.d/offloading")))
- (mkdir-p (dirname authorizations))
- (copy-file (string-append offloading-ssh-key ".pub")
- authorizations)
- (chmod (dirname authorizations) #o555)))
-
- (unless (file-exists? guix-directory)
- (invoke #$(initialize-hurd-vm-substitutes)
- guix-directory))
-
- (when #$(hurd-vm-configuration-offloading? config)
- ;; Authorize the archive signing key from GUIX-DIRECTORY in the host.
- (invoke #$(authorize-guest-substitutes-on-host) guix-directory)))))
+ (build-vm-activation (hurd-vm-configuration-secret-root config)
+ #:offloading?
+ (hurd-vm-configuration-offloading? config)
+ #:offloading-ssh-key
+ (hurd-vm-configuration-offloading-ssh-key config)))
(define (hurd-vm-configuration-offloading-ssh-key config)
"Return the name of the file containing the SSH key of user 'offloading'."
@@ -72,6 +72,7 @@ (define-module (gnu system image)
#:export (root-offset
root-label
image-without-os
+ operating-system-for-image
esp-partition
esp32-partition
@@ -71,6 +71,8 @@ (define-module (gnu system vm)
#:export (virtualized-operating-system
system-qemu-image/shared-store-script
+ linux-image-startup-command
+
virtual-machine
virtual-machine?
virtual-machine-operating-system
@@ -132,7 +134,8 @@ (define (mapping->file-system mapping)
(check? #f)
(create-mount-point? #t)))))
-(define* (virtualized-operating-system os mappings
+(define* (virtualized-operating-system os
+ #:optional (mappings '())
#:key (full-boot? #f) volatile?)
"Return an operating system based on OS suitable for use in a virtualized
environment with the store shared with the host. MAPPINGS is a list of
@@ -316,6 +319,63 @@ (define* (system-qemu-image/shared-store-script os
(gexp->derivation "run-vm.sh" builder)))
+(define* (linux-image-startup-command image
+ #:key
+ (system (%current-system))
+ (target #f)
+ (qemu qemu-minimal)
+ (graphic? #f)
+ (cpu "max")
+ (cpu-count 1)
+ (memory-size 1024)
+ (port-forwardings '())
+ (date #f))
+ "Return a list-valued gexp representing the command to start QEMU to run
+IMAGE, assuming it uses the Linux kernel, and not sharing the store with the
+host."
+ (define os
+ ;; Note: 'image-operating-system' would return the wrong OS, before
+ ;; its root partition has been assigned a UUID.
+ (operating-system-for-image image))
+
+ (define kernel-arguments
+ #~(list #$@(if graphic? #~() #~("console=ttyS0"))
+ #+@(operating-system-kernel-arguments os "/dev/vda1")))
+
+ #~`(#+(file-append qemu "/bin/"
+ (qemu-command (or target system)))
+ ,@(if (access? "/dev/kvm" (logior R_OK W_OK))
+ '("-enable-kvm")
+ '())
+
+ "-cpu" #$cpu
+ #$@(if (> cpu-count 1)
+ #~("-smp" #$(string-append "cpus=" (number->string cpu-count)))
+ #~())
+ "-m" #$(number->string memory-size)
+ "-nic" #$(string-append
+ "user,model=virtio-net-pci,"
+ (port-forwardings->qemu-options port-forwardings))
+ "-kernel" #$(operating-system-kernel-file os)
+ "-initrd" #$(file-append os "/initrd")
+ "-append" ,(string-join #$kernel-arguments)
+ "-serial" "stdio"
+
+ #$@(if date
+ #~("-rtc"
+ #$(string-append "base=" (date->string date "~5")))
+ #~())
+
+ "-object" "rng-random,filename=/dev/urandom,id=guix-vm-rng"
+ "-device" "virtio-rng-pci,rng=guix-vm-rng"
+
+ "-drive"
+ ,(string-append "file=" #$(system-image image)
+ ",format=qcow2,if=virtio,"
+ "cache=writeback,werror=report,readonly=off")
+ "-snapshot"
+ "-no-reboot"))
+
;;;
;;; High-level abstraction.
@@ -33,6 +33,7 @@ (define-module (gnu tests virtualization)
#:use-module (gnu services)
#:use-module (gnu services dbus)
#:use-module (gnu services networking)
+ #:use-module (gnu services ssh)
#:use-module (gnu services virtualization)
#:use-module (gnu packages ssh)
#:use-module (gnu packages virtualization)
@@ -42,7 +43,8 @@ (define-module (gnu tests virtualization)
#:use-module (guix modules)
#:export (%test-libvirt
%test-qemu-guest-agent
- %test-childhurd))
+ %test-childhurd
+ %test-build-vm))
;;;
@@ -241,6 +243,36 @@ (define %childhurd-os
(password "")) ;empty password
%base-user-accounts))))))))
+(define* (run-command-over-ssh command
+ #:key (port 10022) (user "test"))
+ "Return a program that runs COMMAND over SSH and prints the result on standard
+output."
+ (define run
+ (with-extensions (list guile-ssh)
+ #~(begin
+ (use-modules (ssh session)
+ (ssh auth)
+ (ssh popen)
+ (ice-9 match)
+ (ice-9 textual-ports))
+
+ (let ((session (make-session #:user #$user
+ #:port #$port
+ #:host "localhost"
+ #:timeout 120
+ #:log-verbosity 'rare)))
+ (match (connect! session)
+ ('ok
+ (userauth-password! session "")
+ (display
+ (get-string-all
+ (open-remote-input-pipe* session #$@command))))
+ (status
+ (error "could not connect to guest over SSH"
+ session status)))))))
+
+ (program-file "run-command-over-ssh" run))
+
(define (run-childhurd-test)
(define (import-module? module)
;; This module is optional and depends on Guile-Gcrypt, do skip it.
@@ -261,36 +293,6 @@ (define (run-childhurd-test)
(operating-system os)
(memory-size (* 1024 3))))
- (define (run-command-over-ssh . command)
- ;; Program that runs COMMAND over SSH and prints the result on standard
- ;; output.
- (let ()
- (define run
- (with-extensions (list guile-ssh)
- #~(begin
- (use-modules (ssh session)
- (ssh auth)
- (ssh popen)
- (ice-9 match)
- (ice-9 textual-ports))
-
- (let ((session (make-session #:user "test"
- #:port 10022
- #:host "localhost"
- #:timeout 120
- #:log-verbosity 'rare)))
- (match (connect! session)
- ('ok
- (userauth-password! session "")
- (display
- (get-string-all
- (open-remote-input-pipe* session #$@command))))
- (status
- (error "could not connect to childhurd over SSH"
- session status)))))))
-
- (program-file "run-command-over-ssh" run)))
-
(define test
(with-imported-modules '((gnu build marionette))
#~(begin
@@ -356,21 +358,24 @@ (define (run-childhurd-test)
;; 'uname' command.
(marionette-eval
'(begin
- (use-modules (ice-9 popen))
+ (use-modules (ice-9 popen)
+ (ice-9 textual-ports))
(get-string-all
- (open-input-pipe #$(run-command-over-ssh "uname" "-on"))))
+ (open-input-pipe #$(run-command-over-ssh '("uname" "-on")))))
marionette))
(test-assert "guix-daemon up and running"
(let ((drv (marionette-eval
'(begin
- (use-modules (ice-9 popen))
+ (use-modules (ice-9 popen)
+ (ice-9 textual-ports))
(get-string-all
(open-input-pipe
- #$(run-command-over-ssh "guix" "build" "coreutils"
- "--no-grafts" "-d"))))
+ #$(run-command-over-ssh
+ '("guix" "build" "coreutils"
+ "--no-grafts" "-d")))))
marionette)))
;; We cannot compare the .drv with (raw-derivation-file
;; coreutils) on the host: they may differ due to fixed-output
@@ -416,3 +421,102 @@ (define %test-childhurd
"Connect to the GNU/Hurd virtual machine service, aka. a childhurd, making
sure that the childhurd boots and runs its SSH server.")
(value (run-childhurd-test))))
+
+
+;;;
+;;; Virtual build machine.
+;;;
+
+(define %build-vm-os
+ (simple-operating-system
+ (service virtual-build-machine-service-type
+ (virtual-build-machine
+ (cpu-count 1)
+ (memory-size (* 1 1024))))))
+
+(define (run-build-vm-test)
+ (define (import-module? module)
+ ;; This module is optional and depends on Guile-Gcrypt, do skip it.
+ (and (guix-module-name? module)
+ (not (equal? module '(guix store deduplication)))))
+
+ (define os
+ (marionette-operating-system
+ %build-vm-os
+ #:imported-modules (source-module-closure
+ '((gnu services herd)
+ (gnu build install))
+ #:select? import-module?)))
+
+ (define vm
+ (virtual-machine
+ (operating-system os)
+ (memory-size (* 1024 3))))
+
+ (define test
+ (with-imported-modules '((gnu build marionette))
+ #~(begin
+ (use-modules (gnu build marionette)
+ (srfi srfi-64)
+ (ice-9 match))
+
+ (define marionette
+ ;; Emulate as much as the host CPU supports so that, possibly, KVM
+ ;; is available inside as well ("nested KVM"), provided
+ ;; /sys/module/kvm_intel/parameters/nested (or similar) allows it.
+ (make-marionette (list #$vm "-cpu" "max")))
+
+ (test-runner-current (system-test-runner #$output))
+ (test-begin "build-vm")
+
+ (test-assert "service running"
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd)
+ (ice-9 match))
+
+ (start-service 'build-vm))
+ marionette))
+
+ (test-assert "guest SSH up and running"
+ ;; Note: Pass #:peek? #t because due to the way QEMU port
+ ;; forwarding works, connecting to 11022 always works even if the
+ ;; 'sshd' service hasn't been started yet in the guest.
+ (wait-for-tcp-port 11022 marionette
+ #:peek? #t))
+
+ (test-assert "copy-on-write store"
+ ;; Set up a writable store. The root partition is already an
+ ;; overlayfs, which is not suitable as the bottom part of this
+ ;; additional overlayfs; thus, create a tmpfs for the backing
+ ;; store.
+ ;; TODO: Remove this when <virtual-machine> creates a writable
+ ;; store.
+ (marionette-eval
+ '(begin
+ (use-modules (gnu build install)
+ (guix build syscalls))
+
+ (mkdir "/run/writable-store")
+ (mount "none" "/run/writable-store" "tmpfs")
+ (mount-cow-store "/run/writable-store" "/backing-store")
+ (system* "df" "-hT"))
+ marionette))
+
+ (test-equal "offloading"
+ 0
+ (marionette-eval
+ '(and (file-exists? "/etc/guix/machines.scm")
+ (system* "guix" "offload" "test"))
+ marionette))
+
+ (test-end))))
+
+ (gexp->derivation "build-vm-test" test))
+
+(define %test-build-vm
+ (system-test
+ (name "build-vm")
+ (description
+ "Offload to a virtual build machine over SSH.")
+ (value (run-build-vm-test))))