From 7c2523a6b25ec28539d3476bdc57d29db85bcbae Mon Sep 17 00:00:00 2001
From: "Jan (janneke) Nieuwenhuizen" <janneke@gnu.org>
Date: Sat, 29 Aug 2020 23:14:59 +0200
Subject: [PATCH v2] DRAFT services: Add secret-service-type.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Content-Transfer-Encoding: 8bit
Content-Type: text/plain; charset=UTF-8

TODO:

$ ./pre-inst-env guix system disk-image gnu/system/examples/bare-hurd.tmpl
guix system: error: reference to invalid output 'out' of derivation '/gnu/store/189x9ph3piyihbs6asnjkinc5qqwfw1h-secret-service-client.drv'

* split in two?
* switch ownership/co-authorship?

co-authored-by: Ludovic Courtès <ludo@gnu.org>

* gnu/build/secret-service.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
* gnu/services/virtualization.scm (hurd-vm-shepherd-service): Use it to copy
secrets.
(hurd-vm-port): New function.
(hurd-vm-net-options): Use it.
(secret-service-activation): New procedure.
(secret-service-type): New variable.
(%hurd-vm-operating-system): Add it.
* gnu/system/examples/bare-hurd.tmpl (%hurd-os): Add it.
* doc/guix.texi (The Hurd in a Virtual Machine): Document it.
---
 doc/guix.texi                      |  19 ++++
 gnu/build/secret-service.scm       |  68 +++++++++++++
 gnu/local.mk                       |   1 +
 gnu/services/virtualization.scm    | 151 ++++++++++++++++++++++++++---
 gnu/system/examples/bare-hurd.tmpl |  20 ++--
 5 files changed, 238 insertions(+), 21 deletions(-)
 create mode 100644 gnu/build/secret-service.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index 6206a93857..f8e03242b2 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/secret-service.scm b/gnu/build/secret-service.scm
new file mode 100644
index 0000000000..fc817f8c5c
--- /dev/null
+++ b/gnu/build/secret-service.scm
@@ -0,0 +1,68 @@
+;;; 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 secret-service)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 rdelim)
+  #:use-module (guix build utils)
+
+  #:export (hurd-vm-secret-service-copy-secrets))
+
+;;; Commentary:
+;;;
+;;; Utility procedures for copying secrets into a VM.
+;;;
+;;; Code:
+
+(define* (hurd-vm-secret-service-copy-secrets port secret-root #:key (retry 20))
+  "Copy all files under SECRET-ROOT using TCP to secret-service listening at
+local PORT."
+
+  (define (file->file+size+mode file-name)
+    (let ((stat (stat file-name))
+          (target (substring file-name (string-length secret-root))))
+      (list target (stat:size stat) (stat:mode stat))))
+
+  (format (current-error-port) "hurd-vm-secret-service-copy-secrets\n")
+
+  (let ((sock (socket AF_INET SOCK_STREAM 0))
+        (addr (make-socket-address AF_INET INADDR_LOOPBACK port)))
+    ;; connect to wait for port
+    (let loop ((retry retry))
+      (if (zero? retry)
+          (error "connecting to childhurd failed")
+          (catch 'system-error
+            (lambda _
+              (connect sock addr))
+            (lambda (key . args)
+              (format (current-error-port) "connect failed: ~a ~s\n" key args)
+              (sleep 1)
+              (loop (1- retry))))))
+    (format (current-error-port) "connected!\n")
+    ;; copy tree
+    (let* ((files (find-files secret-root))
+           (files-sizes-modes (map file->file+size+mode files))
+           (secrets `(secrets
+                      (version 0)
+                      (files ,files-sizes-modes))))
+      (write secrets sock)
+      (for-each (compose (cute display <> sock)
+                         (cute with-input-from-file <> read-string))
+                files))))
+
+;;; secret-service.scm ends here
diff --git a/gnu/local.mk b/gnu/local.mk
index 8854698178..1d8022fd11 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -659,6 +659,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/build/linux-initrd.scm			\
   %D%/build/linux-modules.scm			\
   %D%/build/marionette.scm			\
+  %D%/build/secret-service.scm			\
   %D%/build/vm.scm				\
 						\
   %D%/tests.scm					\
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index b93ed70099..aa9b06f74b 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 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -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)
@@ -48,6 +49,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 match)
 
   #:export (%hurd-vm-operating-system
@@ -61,7 +63,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
 
@@ -804,6 +809,94 @@ given QEMU package."
 compiled for other architectures using QEMU and the @code{binfmt_misc}
 functionality of the kernel Linux.")))
 
+
+;;;
+;;; Secrets for guest VMs.
+;;;
+
+(define (secret-service-activation port)
+  "Return an activation snippet that fetches sensitive material at PORT, over
+TCP."
+  (define install-secrets
+    (with-imported-modules '((guix build utils))
+      #~(begin
+          (use-modules (guix build utils)
+                       (rnrs io ports)
+                       (rnrs bytevectors)
+                       (ice-9 match))
+
+          (define (wait-for-client port)
+            ;; Wait for a TCP connection on PORT.  Note: We cannot use the
+            ;; virtio-serial ports, which would be safer, because they are
+            ;; (presumably) unsupported on GNU/Hurd.
+            (let ((sock (socket AF_INET SOCK_STREAM 0)))
+              (bind sock AF_INET INADDR_ANY port)
+              (listen sock 1)
+              (format (current-error-port)
+                      "waiting for secrets on port ~a...~%"
+                      port)
+              (match (accept sock)
+                ((client . address)
+                 (format (current-error-port) "client connection from ~a~%"
+                         (inet-ntop (sockaddr:fam address)
+                                    (sockaddr:addr address)))
+                 (close-port sock)
+                 client))))
+
+          ;; TODO: Remove when (@ (guix build utils) dump-port) has a 'size'
+          ;; parameter.
+          (define (dump in out size)
+            ;; Copy SIZE bytes from IN to OUT.
+            (define buf-size 65536)
+            (define buf (make-bytevector buf-size))
+
+            (let loop ((left size))
+              (if (<= left 0)
+                  0
+                  (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
+                    (if (eof-object? read)
+                        left
+                        (begin
+                          (put-bytevector out buf 0 read)
+                          (loop (- left read))))))))
+
+          (define (read-secrets port)
+            ;; Read secret files from PORT and install them.
+            (match (false-if-exception (read port))
+              (('secrets ('version 0)
+                         ('files ((files sizes modes) ...)))
+               (for-each (lambda (file size mode)
+                           (format (current-error-port)
+                                   "installing file '~a' (~a bytes)...~%"
+                                   file size)
+                           (mkdir-p (dirname file))
+                           (call-with-output-file file
+                             (lambda (output)
+                               (dump port output size)
+                               (chmod file mode))))
+                         files sizes modes))
+              (_
+               (format (current-error-port)
+                       "invalid secrets received~%")
+               (sleep 3)
+               (reboot))))
+
+          (let ((port (wait-for-client #$port)))
+            (read-secrets port)
+            (close-port port)))))
+
+  (computed-file "secret-service-client" install-secrets))
+
+(define secret-service-type
+  (service-type
+   (name 'secret-service)
+   (extensions (list (service-extension activation-service-type
+                                        secret-service-activation)))
+   (description
+    "This service fetches secret key and other sensitive material over TCP at
+boot time.  This service is meant to be used by virtual machines (VMs) that
+can only be accessed by their host.")))
+
 
 ;;;
 ;;; The Hurd in VM service: a Childhurd.
@@ -819,6 +912,8 @@ functionality of the kernel Linux.")))
                  (target "/dev/vda")
                  (timeout 0)))
     (services (cons*
+               ;; Receive secret keys on port 5999, TCP.
+               (service secret-service-type 5999)
                (service openssh-service-type
                         (openssh-configuration
                          (openssh openssh-sans-x)
@@ -849,7 +944,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 +958,27 @@ 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-secrets-port 15999)
+(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-secrets-port))
+                    "-:5999"
+                    ",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 +1009,26 @@ 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 secret-service)
+                                                       (guix build utils)))
+        (with-extensions (list guile-ssh)
+          #~(let ((spawn (make-forkexec-constructor #$vm-command)))
+              (lambda _
+                (let ((pid (spawn))
+                      (port #$(hurd-vm-port config %hurd-vm-secrets-port))
+                      (root #$(hurd-vm-configuration-secret-root config)))
+                  (when (and root (directory-exists? root))
+                    (catch #t
+                      (lambda _
+                        (hurd-vm-secret-service-copy-secrets port root))
+                      (lambda (key . args)
+                        (format (current-error-port) "childhurd: ~a ~s\n" key args))))
+                  pid))))))
+      (modules `((gnu build secret-service)
+                 (guix build utils)
+                 ,@%default-modules))
       (stop  #~(make-kill-destructor))))))
 
 (define hurd-vm-service-type
diff --git a/gnu/system/examples/bare-hurd.tmpl b/gnu/system/examples/bare-hurd.tmpl
index 414a9379c8..2d00a7c8bb 100644
--- a/gnu/system/examples/bare-hurd.tmpl
+++ b/gnu/system/examples/bare-hurd.tmpl
@@ -41,14 +41,16 @@
     (host-name "guixygnu")
     (timezone "Europe/Amsterdam")
     (packages (cons openssh-sans-x %base-packages/hurd))
-    (services (cons (service openssh-service-type
-                             (openssh-configuration
-                              (openssh openssh-sans-x)
-                              (use-pam? #f)
-                              (port-number 2222)
-                              (permit-root-login #t)
-                              (allow-empty-passwords? #t)
-                              (password-authentication? #t)))
-               %base-services/hurd))))
+    (services (append (list (service openssh-service-type
+                                     (openssh-configuration
+                                      (openssh openssh-sans-x)
+                                      (use-pam? #f)
+                                      (port-number 2222)
+                                      (permit-root-login #t)
+                                      (allow-empty-passwords? #t)
+                                      (password-authentication? #t)))
+                            (service (@@ (gnu services virtualization)
+                                         secret-service-type) 5999))
+                      %base-services/hurd))))
 
 %hurd-os
-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.com

