services: Add secret-service-type.

This adds a "secret-service" that can be added to a Childhurd VM to receive
out-of-band secrets (keys) sent from the host.

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

* gnu/services/virtualization.scm (secret-service-activation): New procedure.
(secret-service-type): New variable.
* gnu/build/secret-service.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.

3 files changed, 166 insertions, 1 deletions

diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm
new file mode 100644
index 0000000000..781651e90d
--- /dev/null
+++ b/gnu/build/secret-service.scm
@@ -0,0 +1,137 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;; 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 (guix build utils)
+
+  #:use-module (srfi srfi-26)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+
+  #:export (secret-service-receive-secrets
+            secret-service-send-secrets))
+
+;;; Commentary:
+;;;
+;;; Utility procedures for copying secrets into a VM.
+;;;
+;;; Code:
+
+(define* (secret-service-send-secrets port secret-root #:key (retry 60))
+  "Copy all files under SECRET-ROOT using TCP to secret-service listening at
+local PORT.  If connect fails, sleep 1s and retry RETRY times."
+
+  (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) "sending secrets to ~a~%" port)
+  (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))
+      (catch 'system-error
+        (cute connect sock addr)
+        (lambda (key . args)
+          (when (zero? retry)
+            (apply throw key args))
+          (format (current-error-port) "retrying connection~%")
+          (sleep 1)
+          (loop (1- retry)))))
+
+    (format (current-error-port) "connected!  sending files in ~s %~"
+            secret-root)
+    (let* ((files (if secret-root (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 dump-port <> sock)
+                         (cute open-input-file <>))
+                files))))
+
+(define (secret-service-receive-secrets port)
+  "Listen to local PORT and wait for a secret service client to send secrets.
+Write them to the file system."
+
+  (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~%")
+       #f)))
+
+  (let* ((port (wait-for-client port))
+         (result (read-secrets port)))
+    (close-port port)
+    result))
+
+;;; secret-service.scm ends here
diff --git a/gnu/local.mk b/gnu/local.mk
index 67cc13d35e..dfb9640b47 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..6d6734dcd1 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.
@@ -806,6 +806,33 @@ functionality of the kernel Linux.")))
 
 
 ;;;
+;;; Secrets for guest VMs.
+;;;
+
+(define (secret-service-activation port)
+  "Return an activation snippet that fetches sensitive material at local PORT,
+over TCP.  Reboot upon failure."
+  (with-imported-modules '((gnu build secret-service)
+                           (guix build utils))
+    #~(begin
+        (use-modules (gnu build secret-service))
+        (let ((sent (secret-service-receive-secrets #$port)))
+          (unless sent
+            (sleep 3)
+            (reboot))))))
+
+(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.
 ;;;