diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/services/virtualization.scm | 602 | ||||
| -rw-r--r-- | gnu/system/image.scm | 1 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 62 | ||||
| -rw-r--r-- | gnu/tests/virtualization.scm | 176 |
4 files changed, 674 insertions, 167 deletions
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index 5b8566f600..cc95dfdf22 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 <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 @@ -1066,6 +1076,461 @@ that will be listening to receive secret keys on ADDRESS." ;;; +;;; 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)) - #~(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 5456b3a5a0..3082bcff46 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -72,6 +72,7 @@ #: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 @@ #: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. 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 @@ #: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" - "--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 @@ "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)))) |