services: Add ‘virtual-build-machine’ service.

* gnu/services/virtualization.scm (<virtual-build-machine>): New record type.
(%build-vm-ssh-port, %build-vm-secrets-port, %x86-64-intel-cpu-models):
New variables.
(qemu-cpu-model-for-date, virtual-build-machine-ssh-port)
(virtual-build-machine-secrets-port): New procedures.
(%minimal-vm-syslog-config, %virtual-build-machine-operating-system):
New variables.
(virtual-build-machine-default-image):
(virtual-build-machine-account-name)
(virtual-build-machine-accounts)
(build-vm-shepherd-services)
(initialize-build-vm-substitutes)
(build-vm-activation)
(virtual-build-machine-offloading-ssh-key)
(virtual-build-machine-activation)
(virtual-build-machine-secret-root)
(check-vm-availability)
(build-vm-guix-extension): New procedures.
(initialize-hurd-vm-substitutes): Remove.
(hurd-vm-activation): Rewrite in terms of ‘build-vm-activation’.
* gnu/system/vm.scm (linux-image-startup-command): New procedure.
(operating-system-for-image): Export.
* gnu/tests/virtualization.scm (run-command-over-ssh): New procedure,
extracted from…
(run-childhurd-test): … here.
[test]: Adjust accordingly.
(%build-vm-os): New variable.
(run-build-vm-test): New procedure.
(%test-build-vm): New variable.
* doc/guix.texi (Virtualization Services)[Virtual Build Machines]: New
section.
(Build Environment Setup): Add cross-reference.

Change-Id: I0a47652a583062314020325aedb654f11cb2499c
This commit is contained in:
Ludovic Courtès 2024-01-20 14:55:46 +01:00
parent 5f34796dc4
commit 9edbb2d7a4
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
5 changed files with 811 additions and 167 deletions

View file

@ -1297,6 +1297,11 @@ environment variable is set to the non-existent
@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},
@ -36334,6 +36339,138 @@ host. If empty, QEMU uses a default file name.
@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

View file

@ -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,461 @@ (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 to a date "in the past" assuming a common use case
;; is to rebuild old packages.
(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 +1755,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'."

View file

@ -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

View file

@ -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 builder
(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.

View file

@ -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 vm
(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 marionette
;; '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))))