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

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
 

gnu/services/virtualization.scm

@@ -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 @@
   #: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 @@
   #: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 @@ that will be listening to receive secret keys on ADDRESS."
                          (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 @@ is added to the OS specified in CONFIG."
          (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))
+  (build-vm-activation (hurd-vm-configuration-secret-root config)
-    #~(begin
+                       #:offloading?
-        (use-modules (guix build utils))
+                       (hurd-vm-configuration-offloading? config)
-
+                       #:offloading-ssh-key
-        (define secret-directory
+                       (hurd-vm-configuration-offloading-ssh-key config)))
-          #$(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)))))
 
 (define (hurd-vm-configuration-offloading-ssh-key config)
   "Return the name of the file containing the SSH key of user 'offloading'."

gnu/system/image.scm

@@ -72,6 +72,7 @@
   #:export (root-offset
             root-label
             image-without-os
+            operating-system-for-image
 
             esp-partition
             esp32-partition

gnu/system/vm.scm

@@ -71,6 +71,8 @@
   #: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 @@
        (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 @@ useful when FULL-BOOT?  is true."
 
     (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.

gnu/tests/virtualization.scm

@@ -33,6 +33,7 @@
   #: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 @@
   #:use-module (guix modules)
   #:export (%test-libvirt
             %test-qemu-guest-agent
-            %test-childhurd))
+            %test-childhurd
+            %test-build-vm))
 
 
 ;;;
@@ -241,6 +243,36 @@
                                  (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 @@
      (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 @@
             ;; '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"
+                             #$(run-command-over-ssh
-                                                     "--no-grafts" "-d"))))
+                                '("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 @@
     "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))))