From patchwork Tue Jan 23 16:48:21 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 59350 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 476A427BBE9; Tue, 23 Jan 2024 16:50:21 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H5,RCVD_IN_MSPIKE_WL, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id A9E5B27BBE2 for ; Tue, 23 Jan 2024 16:50:15 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rSJyL-0004FI-MF; Tue, 23 Jan 2024 11:50:01 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJyI-0004F0-0U for guix-patches@gnu.org; Tue, 23 Jan 2024 11:49:58 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rSJyH-0004Zv-Oi for guix-patches@gnu.org; Tue, 23 Jan 2024 11:49:57 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1rSJyM-0004CJ-Ei for guix-patches@gnu.org; Tue, 23 Jan 2024 11:50:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#68677] [PATCH 6/6] services: Add =?utf-8?b?4oCYdmlydHVhbC1i?= =?utf-8?b?dWlsZC1tYWNoaW5l4oCZ?= service. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 23 Jan 2024 16:50:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 68677 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 68677@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 68677-submit@debbugs.gnu.org id=B68677.170602855215990 (code B ref 68677); Tue, 23 Jan 2024 16:50:02 +0000 Received: (at 68677) by debbugs.gnu.org; 23 Jan 2024 16:49:12 +0000 Received: from localhost ([127.0.0.1]:43895 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxW-00049l-FA for submit@debbugs.gnu.org; Tue, 23 Jan 2024 11:49:12 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:39924) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rSJxF-00046r-EU for 68677@debbugs.gnu.org; Tue, 23 Jan 2024 11:48:55 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rSJx4-0004M5-Kv; Tue, 23 Jan 2024 11:48:43 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=Tp3/U65F9VB3bDmGJi9a7MNBxCDI5zF9QPgrbhYmLr0=; b=a/a+3Myh6TYvyFifTvCI saMCMC8xVEq1j+I6KlbeJp5nCOhWGwrDQCKaYXPVBCMambg6oNA81aKo2p1FpuqtBxcq4mC+5cRjh vbCY7I/0Lhs8FgffllLxI0HcHnVU109Z1/z5d+0RbD4ARmIve8xfphsJ4yQMn5sr35/p6KN7nw5pj vK39JtVHT8T6zQE3usHvGxoMwv/tV76ok8uV1SXi4ewKw5lHNVjHFz+9oU7/MxHaMguGYr39WqWbW bNZwK2BCIb43M7Qu81IJPLQ5O/9WXTEaGRPBlEvsh3fOWY9JUNEAnIpB167/nDY2SPgcJ6J/vb2Ml Ou6EyXshzogzew==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 23 Jan 2024 17:48:21 +0100 Message-ID: X-Mailer: git-send-email 2.41.0 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * gnu/services/virtualization.scm (): 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 --- doc/guix.texi | 139 +++++++- gnu/services/virtualization.scm | 600 +++++++++++++++++++++++++------- gnu/system/image.scm | 1 + gnu/system/vm.scm | 62 +++- gnu/tests/virtualization.scm | 176 ++++++++-- 5 files changed, 810 insertions(+), 168 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index ac17f91f7d..04a6bf2bcd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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 diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index 5b8566f600..907d641c6a 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ryan Moe -;;; Copyright © 2018, 2020-2023 Ludovic Courtès +;;; Copyright © 2018, 2020-2024 Ludovic Courtès ;;; Copyright © 2020, 2021, 2023 Janneke Nieuwenhuizen ;;; Copyright © 2021 Timotej Lazar ;;; Copyright © 2022 Oleg Pykhalov @@ -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 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 + ;; . + ;; 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 + (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 , 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'." diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 2cc1012893..87df2fa088 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -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 diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index ef4c180058..fcfd1cdb48 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -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. diff --git a/gnu/tests/virtualization.scm b/gnu/tests/virtualization.scm index 6ca88cbacd..c8b42eb1db 100644 --- a/gnu/tests/virtualization.scm +++ b/gnu/tests/virtualization.scm @@ -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 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))))