[bug#43106] [PATCH] DRAFT services: childhurd: Support for setting secrets.

[Jan (janneke) Nieuwenhuizen]

TODO: This seems to work...but it can keep the shepherd from finishing for
quite some time (half a minute)...not sure what to do here, WDYT?

A great way to play with it is by doing something like

--8<---------------cut here---------------start------------->8---
sudo -E ./pre-inst-env guile -c '(use-modules (gnu build childhurd)) 
(hurd-vm-copy-secrets 10022 "/etc/childhurd")'
--8<---------------cut here---------------end--------------->8---

* gnu/build/childhurd.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
* gnu/services/virtualization.scm (hurd-vm-shepherd-service): Use it to set
secrets.
(hurd-vm-port): New function.
(hurd-vm-net-options): Use it.
* doc/guix.texi (The Hurd in a Virtual Machine): Document it.
---
 doc/guix.texi                   | 19 ++++++++
 gnu/build/childhurd.scm         | 77 +++++++++++++++++++++++++++++++++
 gnu/local.mk                    |  1 +
 gnu/services/virtualization.scm | 52 +++++++++++++++++-----
 4 files changed, 138 insertions(+), 11 deletions(-)
 create mode 100644 gnu/build/childhurd.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index 0b79a49814..334ee5e05c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -25119,6 +25119,7 @@ Return the name of @var{platform}---a string such as 
@code{"arm"}.
 
 @cindex @code{hurd}
 @cindex the Hurd
+@cindex childhurd
 
 Service @code{hurd-vm} provides support for running GNU/Hurd in a
 virtual machine (VM), a so-called ``Childhurd''.  The virtual machine is
@@ -25200,6 +25201,24 @@ with forwarded ports
 <vnc-port>: @code{(+ 15900 (* 1000 @var{ID}))}
 @end example
 
+@item @code{secret-root} (default: @code{#f})
+If set, the root directory with out-of-band secrets to be injected into
+the childhurd once it runs.  Childhurds are volatile which means that on
+every startup, secrets such as the SSH host keys and Guix signing key
+are recreated.
+
+Typical use is setting @code{secret-root} to @code{"/etc/childhurd"}
+pointing at a tree of non-volatile secrets like so
+
+@example
+/etc/childhurd/etc/guix/signing-key.pub
+/etc/childhurd/etc/guix/signing-key.sec
+/etc/childhurd/etc/ssh/ssh_host_ed25519_key
+/etc/childhurd/etc/ssh/ssh_host_ecdsa_key
+/etc/childhurd/etc/ssh/ssh_host_ed25519_key.pub
+/etc/childhurd/etc/ssh/ssh_host_ecdsa_key.pub
+@end example
+
 @end table
 @end deftp
 
diff --git a/gnu/build/childhurd.scm b/gnu/build/childhurd.scm
new file mode 100644
index 0000000000..87c5cc0cd0
--- /dev/null
+++ b/gnu/build/childhurd.scm
@@ -0,0 +1,77 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu build childhurd)
+  #:use-module (ice-9 rdelim)
+  #:use-module (guix build utils)
+
+  ;; #:use-module (ssh auth)
+  ;; #:use-module (ssh channel)
+  ;; #:use-module (ssh session)
+  ;; #:use-module (ssh sftp)
+
+  #:autoload (ssh auth) (userauth-password!)
+  #:autoload (ssh channel) (make-channel
+                            channel-open-session channel-request-exec
+                            channel-get-exit-status)
+  #:autoload (ssh session) (make-session connect! disconnect!)
+  #:autoload (ssh sftp) (make-sftp-session
+                         call-with-remote-output-file sftp-chmod)
+
+  #:export (hurd-vm-copy-secrets))
+
+;;; Commentary:
+;;;
+;;; Utility procedures for a childhurd.
+;;;
+;;; Code:
+
+(define* (hurd-vm-copy-secrets port secret-root #:key (retry 20))
+  "Copy all files under SECRET-ROOT using ssh to childhurd at local PORT."
+  (format (current-error-port) "hurd-vm-copy-secrets\n")
+  (let ((session (make-session #:host "127.0.0.1" #:port port
+                               #:user "root")))
+    (let loop ((result (connect! session)) (retry retry))
+      (unless (equal? result 'ok)
+        (format (current-error-port) "Waiting for childhurd...\n")
+        (when (zero? retry)
+          (error "Could not connect childhurd" session result))
+        (sleep 1)
+        (disconnect! session)
+        (loop (connect! session) (1- retry))))
+    (let ((result (userauth-password! session "")))
+      (unless (equal? result 'success)
+        (error "Could not set userauth-password" session result)))
+    (let ((sftp-session (make-sftp-session session)))
+      (define (copy-file source)
+        (let ((text (with-input-from-file source read-string))
+              (mode (stat:mode (stat source)))
+              (target (substring source (string-length secret-root))))
+          (call-with-remote-output-file sftp-session target
+                                        ;;(cute display text <>)
+                                        (lambda (port) (display text port)))
+          (sftp-chmod sftp-session target mode)))
+      (for-each copy-file (find-files secret-root))
+      (let ((channel (make-channel session)))
+        (channel-open-session channel)
+        (channel-request-exec channel "herd restart sshd")
+        (unless (zero? (channel-get-exit-status channel))
+          (error "Failed to restart sshd"))))
+    (disconnect! session)))
+
+;;; childhurd.scm ends here
diff --git a/gnu/local.mk b/gnu/local.mk
index d956e52d97..f872f1ba77 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -648,6 +648,7 @@ GNU_SYSTEM_MODULES =                                \
   %D%/build/accounts.scm                       \
   %D%/build/activation.scm                     \
   %D%/build/bootloader.scm                     \
+  %D%/build/childhurd.scm                      \
   %D%/build/cross-toolchain.scm                        \
   %D%/build/image.scm                          \
   %D%/build/file-systems.scm                   \
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index b93ed70099..f496c06764 100644
--- a/gnu/services/virtualization.scm
+++ b/gnu/services/virtualization.scm
@@ -39,6 +39,7 @@
   #:use-module (gnu system)
   #:use-module (guix derivations)
   #:use-module (guix gexp)
+  #:use-module (guix modules)
   #:use-module (guix monads)
   #:use-module (guix packages)
   #:use-module (guix records)
@@ -61,7 +62,10 @@
             hurd-vm-configuration-options
             hurd-vm-configuration-id
             hurd-vm-configuration-net-options
+            hurd-vm-configuration-secrets
+
             hurd-vm-disk-image
+            hurd-vm-port
             hurd-vm-net-options
             hurd-vm-service-type
 
@@ -849,7 +853,9 @@ functionality of the kernel Linux.")))
                (default #f))
   (net-options hurd-vm-configuration-net-options        ;list of string
                (thunked)
-               (default (hurd-vm-net-options this-record))))
+               (default (hurd-vm-net-options this-record)))
+  (secret-root hurd-vm-configuration-secret-root        ;#f or string
+               (default #f)))
 
 (define (hurd-vm-disk-image config)
   "Return a disk-image for the Hurd according to CONFIG."
@@ -861,15 +867,23 @@ functionality of the kernel Linux.")))
       (size disk-size)
       (operating-system os)))))
 
-(define (hurd-vm-net-options config)
+(define (hurd-vm-port config base)
+  "Return the forwarded vm port for this childhurd config."
   (let ((id (or (hurd-vm-configuration-id config) 0)))
-    (define (qemu-vm-port base)
-      (number->string (+ base (* 1000 id))))
-    `("--device" "rtl8139,netdev=net0"
-      "--netdev" ,(string-append
-                   "user,id=net0"
-                   ",hostfwd=tcp:127.0.0.1:" (qemu-vm-port 10022) "-:2222"
-                   ",hostfwd=tcp:127.0.0.1:" (qemu-vm-port 15900) "-:5900"))))
+    (+ base (* 1000 id))))
+(define %hurd-vm-ssh-port 10022)
+(define %hurd-vm-vnc-port 15900)
+
+(define (hurd-vm-net-options config)
+  `("--device" "rtl8139,netdev=net0"
+    "--netdev"
+    ,(string-append "user,id=net0"
+                    ",hostfwd=tcp:127.0.0.1:"
+                    (number->string (hurd-vm-port config %hurd-vm-ssh-port))
+                    "-:2222"
+                    ",hostfwd=tcp:127.0.0.1:"
+                    (number->string (hurd-vm-port config %hurd-vm-vnc-port))
+                    "-:5900")))
 
 (define (hurd-vm-shepherd-service config)
   "Return a <shepherd-service> for a Hurd in a Virtual Machine with CONFIG."
@@ -900,8 +914,24 @@ functionality of the kernel Linux.")))
                             (string->symbol (number->string id)))
                       provisions)
                      provisions))
-      (requirement '(networking))
-      (start #~(make-forkexec-constructor #$vm-command))
+      (requirement '(loopback networking user-processes))
+      (start
+       (with-imported-modules (source-module-closure '((gnu build childhurd)
+                                                       (guix build utils)))
+        (with-extensions (list guile-ssh)
+          #~(let ((spawn (make-forkexec-constructor #$vm-command)))
+              (use-modules (gnu build childhurd))
+              (lambda _
+                (let ((pid (spawn))
+                      (port #$(hurd-vm-port config %hurd-vm-ssh-port))
+                      (root #$(hurd-vm-configuration-secret-root config)))
+                  (when (and root (directory-exists? root))
+                    (catch #t
+                      (lambda _
+                        (hurd-vm-copy-secrets port root))
+                      (lambda (key . args)
+                        (format (current-error-port) "childhurd: ~a ~s\n" key 
args))))
+                  pid))))))
       (stop  #~(make-kill-destructor))))))
 
 (define hurd-vm-service-type
-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.com