mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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
parent
5f34796dc4
commit
9edbb2d7a4
5 changed files with 811 additions and 167 deletions
137
doc/guix.texi
137
doc/guix.texi
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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'."
|
||||
|
|
|
|||
|
|
@ -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 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.
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue