services: hurd-vm: Implement zero-configuration offloading.

This allows for zero-configuration offloading to a childhurd.

* gnu/services/virtualization.scm (operating-system-with-offloading-account):
New procedure.
(<hurd-vm-configuration>)[offloading?]: New field.
(hurd-vm-disk-image): Define ‘transform’ and use it.
(hurd-vm-activation): Generate SSH key for user ‘offloading’ and add
authorize it via /etc/childhurd/etc/ssh/authorized_keys.d.
(hurd-vm-configuration-offloading-ssh-key)
(hurd-vm-guix-extension): New procedures.
(hurd-vm-service-type): Add GUIX-SERVICE-TYPE extension.
* gnu/tests/virtualization.scm (run-childhurd-test)[import-module?]: New
procedure.
[os]: Add (gnu build install) and its closure to #:import-modules.
[test]: Add “copy-on-write store” and “offloading” tests.
* doc/guix.texi (Virtualization Services): Document it.

2 files changed, 124 insertions, 6 deletions

diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index 930c2ce702..076eca7ea2 100644
--- a/gnu/services/virtualization.scm
+++ b/gnu/services/virtualization.scm
@@ -27,6 +27,7 @@
   #:use-module (gnu bootloader grub)
   #:use-module (gnu image)
   #:use-module (gnu packages admin)
+  #:use-module (gnu packages bash)
   #:use-module (gnu packages gdb)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu packages package-management)
@@ -52,6 +53,7 @@
   #:use-module (guix store)
   #:use-module (guix utils)
   #:autoload   (guix self) (make-config.scm)
+  #:autoload   (guix platform) (platform-system)
 
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
@@ -1063,6 +1065,26 @@ that will be listening to receive secret keys on port 1004, TCP."
 ;;; The Hurd in VM service: a Childhurd.
 ;;;
 
+(define (operating-system-with-offloading-account os)
+  (define accounts
+    (list (user-group
+           (name "offloading")
+           (system? #t))
+          (user-account
+           (name "offloading")
+           (group "offloading")
+           (system? #t)
+           (comment "Offloading privilege separation user")
+           (home-directory "/var/run/offloading")
+           (shell (file-append bash-minimal "/bin/sh")))))
+
+  (operating-system
+    (inherit os)
+    (services (cons (simple-service 'offloading-account
+                                    account-service-type
+                                    accounts)
+                    (operating-system-user-services os)))))
+
 (define %hurd-vm-operating-system
   (operating-system
     (inherit %hurd-default-operating-system)
@@ -1115,14 +1137,21 @@ that will be listening to receive secret keys on port 1004, TCP."
   (net-options hurd-vm-configuration-net-options        ;list of string
                (thunked)
                (default (hurd-vm-net-options this-record)))
+  (offloading? hurd-vm-configuration-offloading?        ;Boolean
+               (default #t))
   (secret-root hurd-vm-configuration-secret-root        ;string
                (default "/etc/childhurd")))
 
 (define (hurd-vm-disk-image config)
   "Return a disk-image for the Hurd according to CONFIG.  The secret-service
 is added to the OS specified in CONFIG."
-  (let* ((os        (secret-service-operating-system
-                     (hurd-vm-configuration-os config)))
+  (define transform
+    (compose secret-service-operating-system
+             (if (hurd-vm-configuration-offloading? config)
+                 operating-system-with-offloading-account
+                 identity)))
+
+  (let* ((os        (transform (hurd-vm-configuration-os config)))
          (disk-size (hurd-vm-configuration-disk-size config))
          (type      (lookup-image-type-by-name 'hurd-qcow2))
          (os->image (image-type-constructor type)))
@@ -1331,18 +1360,71 @@ an argument) on the host."
         (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))
 
-        ;; Authorize the archive signing key from GUIX-DIRECTORY in the host.
-        (invoke #$(authorize-guest-substitutes-on-host) 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'."
+  (string-append "/etc/guix/offload/ssh/childhurd"
+                 (or (and=> (hurd-vm-configuration-id config)
+                            number->string)
+                     "")))
+
+(define (hurd-vm-guix-extension config)
+  "When offloading is enabled, add this childhurd to the list of offlading
+machines in /etc/guix/machines.scm."
+  (if (hurd-vm-configuration-offloading? config)
+      (let* ((image (hurd-vm-configuration-image config))
+             (platform (image-platform image))
+             (system (platform-system platform))
+             (vm-ssh-key (string-append
+                          (hurd-vm-configuration-secret-root config)
+                          "/etc/ssh/ssh_host_ed25519_key.pub"))
+             (host-ssh-key (hurd-vm-configuration-offloading-ssh-key config)))
+        (guix-extension
+         (build-machines
+          (list #~(build-machine
+                   (name "localhost")
+                   (port #$(hurd-vm-port config %hurd-vm-ssh-port))
+                   (systems '(#$system))
+                   (host-key (call-with-input-file #$vm-ssh-key
+                               (@ (ice-9 textual-ports)
+                                  get-string-all)))
+                   (user "offloading")
+                   (private-key #$host-ssh-key))))))
+      (guix-extension)))
 
 (define hurd-vm-service-type
   (service-type
@@ -1351,6 +1433,8 @@ an argument) on the host."
                                         hurd-vm-shepherd-service)
                      (service-extension account-service-type
                                         (const %hurd-vm-accounts))
+                     (service-extension guix-service-type
+                                        hurd-vm-guix-extension)
                      (service-extension activation-service-type
                                         hurd-vm-activation)))
    (default-value (hurd-vm-configuration))
diff --git a/gnu/tests/virtualization.scm b/gnu/tests/virtualization.scm
index 599e58edf0..b79164737b 100644
--- a/gnu/tests/virtualization.scm
+++ b/gnu/tests/virtualization.scm
@@ -38,6 +38,7 @@
   #:use-module (guix gexp)
   #:use-module (guix records)
   #:use-module (guix store)
+  #:use-module (guix modules)
   #:export (%test-libvirt
             %test-qemu-guest-agent
             %test-childhurd))
@@ -244,11 +245,19 @@
                                   (permit-root-login #t)))))))))))
 
 (define (run-childhurd-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
      %childhurd-os
-     #:imported-modules '((gnu services herd)
-                          (guix combinators))))
+     #:imported-modules (source-module-closure
+                         '((gnu services herd)
+                           (guix combinators)
+                           (gnu build install))
+                         #:select? import-module?)))
 
   (define vm
     (virtual-machine
@@ -373,6 +382,31 @@
                                    (pk 'drv (string-trim-right drv)))
                    drv)))
 
+          (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 "childhurd-test" test))