services: secret-service: Make the endpoint configurable.

Until now, the secret service had a hard-coded TCP endpoint on port
1004.  This change lets users specify arbitrary socket addresses.

* gnu/build/secret-service.scm (socket-address->string): New procedure,
taken from Shepherd.
(secret-service-send-secrets): Replace ‘port’ by ‘address’ and adjust
accordingly.
(secret-service-receive-secrets): Likewise.
* gnu/services/virtualization.scm (secret-service-shepherd-services):
Likewise.
(secret-service-operating-system): Add optional ‘address’ parameter and
honor it.  Adjust ‘start’ method accordingly.

Change-Id: I87a9514f1c170dca756ce76083d7182c6ebf6578

2 files changed, 63 insertions, 39 deletions

diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm
index e13fd4eef3..0226c64032 100644
--- a/gnu/build/secret-service.scm
+++ b/gnu/build/secret-service.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -93,13 +93,28 @@ Return #t in the former case and #f in the latter case."
            ('readable #t)
            ('timeout  #f)))))))
 
-(define* (secret-service-send-secrets port secret-root
+(define (socket-address->string address)
+  "Return a human-readable representation of ADDRESS, an object as returned by
+'make-socket-address'."
+  (let ((family (sockaddr:fam address)))
+    (cond ((= AF_INET family)
+           (string-append (inet-ntop AF_INET (sockaddr:addr address))
+                          ":" (number->string (sockaddr:port address))))
+          ((= AF_INET6 family)
+           (string-append "[" (inet-ntop AF_INET6 (sockaddr:addr address)) "]"
+                          ":" (number->string (sockaddr:port address))))
+          ((= AF_UNIX family)
+           (sockaddr:path address))
+          (else
+           (object->string address)))))
+
+(define* (secret-service-send-secrets address secret-root
                                       #:key (retry 60)
                                       (handshake-timeout 180))
-  "Copy all files under SECRET-ROOT using TCP to secret-service listening at
-local PORT.  If connect fails, sleep 1s and retry RETRY times; once connected,
-wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
-#f on failure."
+  "Copy all files under SECRET-ROOT by connecting to secret-service listening
+at ADDRESS, an address as returned by 'make-socket-address'.  If connection
+fails, sleep 1s and retry RETRY times; once connected, wait for at most
+HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return #f on failure."
   (define (file->file+size+mode file-name)
     (let ((stat (stat file-name))
           (target (substring file-name (string-length secret-root))))
@@ -118,9 +133,9 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
                       (dump-port input sock))))
                 files)))
 
-  (log "sending secrets to ~a~%" port)
+  (log "sending secrets to ~a~%" (socket-address->string address))
+
   (let ((sock (socket AF_INET (logior SOCK_CLOEXEC SOCK_STREAM) 0))
-        (addr (make-socket-address AF_INET INADDR_LOOPBACK port))
         (sleep (if (resolve-module '(fibers) #f)
                    (module-ref (resolve-interface '(fibers)) 'sleep)
                    sleep)))
@@ -129,7 +144,7 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
     ;; forward port inside the guest.
     (let loop ((retry retry))
       (catch 'system-error
-        (cute connect sock addr)
+        (cute connect sock address)
         (lambda (key . args)
           (when (zero? retry)
             (apply throw key args))
@@ -147,7 +162,8 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
           (('secret-service-server ('version version ...))
            (log "sending files from ~s...~%" secret-root)
            (send-files sock)
-           (log "done sending files to port ~a~%" port)
+           (log "done sending files to ~a~%"
+                (socket-address->string address))
            (close-port sock)
            secret-root)
           (x
@@ -155,7 +171,8 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
            (close-port sock)
            #f))
         (begin                                    ;timeout
-         (log "timeout while sending files to ~a~%" port)
+         (log "timeout while sending files to ~a~%"
+              (socket-address->string address))
          (close-port sock)
          #f))))
 
@@ -168,19 +185,20 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
       (unless (= ENOENT (system-error-errno args))
         (apply throw args)))))
 
-(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.  Return the list of files installed on success,
-and #f otherwise."
+(define (secret-service-receive-secrets address)
+  "Listen to ADDRESS, an address returned by 'make-socket-address', and wait
+for a secret service client to send secrets.  Write them to the file system.
+Return the list of files installed on success, and #f otherwise."
 
-  (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.
+  (define (wait-for-client address)
+    ;; Wait for a connection on ADDRESS.  Note: virtio-serial ports are safer
+    ;; than TCP connections but they are (presumably) unsupported on GNU/Hurd.
     (let ((sock (socket AF_INET (logior SOCK_CLOEXEC SOCK_STREAM) 0)))
-      (bind sock AF_INET INADDR_ANY port)
+      (bind sock address)
       (listen sock 1)
-      (log "waiting for secrets on port ~a...~%" port)
+      (log "waiting for secrets on ~a...~%"
+           (socket-address->string address))
+
       (match (select (list sock) '() '() 60)
         (((_) () ())
          (match (accept sock)
@@ -244,7 +262,7 @@ and #f otherwise."
        (log "invalid secrets received~%")
        #f)))
 
-  (let* ((port   (wait-for-client port))
+  (let* ((port   (wait-for-client address))
          (result (and=> port read-secrets)))
     (when port
       (close-port port))
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index f0f0ab3bf1..5b8566f600 100644
--- a/gnu/services/virtualization.scm
+++ b/gnu/services/virtualization.scm
@@ -996,7 +996,7 @@ specified, the QEMU default path is used."))
 ;;; Secrets for guest VMs.
 ;;;
 
-(define (secret-service-shepherd-services port)
+(define (secret-service-shepherd-services address)
   "Return a Shepherd service that fetches sensitive material at local PORT,
 over TCP.  Reboot upon failure."
   ;; This is a Shepherd service, rather than an activation snippet, to make
@@ -1018,7 +1018,7 @@ over TCP.  Reboot upon failure."
                          "receiving secrets from the host...~%")
                  (force-output (current-error-port))
 
-                 (let ((sent (secret-service-receive-secrets #$port)))
+                 (let ((sent (secret-service-receive-secrets #$address)))
                    (unless sent
                      (sleep 3)
                      (reboot))))))
@@ -1039,9 +1039,13 @@ over TCP.  Reboot upon failure."
 boot time.  This service is meant to be used by virtual machines (VMs) that
 can only be accessed by their host.")))
 
-(define (secret-service-operating-system os)
+(define* (secret-service-operating-system os
+                                          #:optional
+                                          (address
+                                           #~(make-socket-address
+                                              AF_INET INADDR_ANY 1004)))
   "Return an operating system based on OS that includes the secret-service,
-that will be listening to receive secret keys on port 1004, TCP."
+that will be listening to receive secret keys on ADDRESS."
   (operating-system
     (inherit os)
     (services
@@ -1049,7 +1053,7 @@ that will be listening to receive secret keys on port 1004, TCP."
      ;; activation: that requires entropy and thus takes time during boot, and
      ;; those keys are going to be overwritten by secrets received from the
      ;; host anyway.
-     (cons (service secret-service-type 1004)
+     (cons (service secret-service-type address)
            (modify-services (operating-system-user-services os)
              (openssh-service-type
               config => (openssh-configuration
@@ -1243,24 +1247,26 @@ is added to the OS specified in CONFIG."
            (source-module-closure '((gnu build secret-service)
                                     (guix build utils)))
          #~(lambda ()
-             (let ((pid  (fork+exec-command #$vm-command
-                                            #:user "childhurd"
-                                            ;; XXX TODO: use "childhurd" after
-                                            ;; updating Shepherd
-                                            #:group "kvm"
-                                            #:environment-variables
-                                            ;; QEMU tries to write to /var/tmp
-                                            ;; by default.
-                                            '("TMPDIR=/tmp")))
-                   (port #$(hurd-vm-port config %hurd-vm-secrets-port))
-                   (root #$(hurd-vm-configuration-secret-root config)))
+             (let* ((pid  (fork+exec-command #$vm-command
+                                             #:user "childhurd"
+                                             ;; XXX TODO: use "childhurd" after
+                                             ;; updating Shepherd
+                                             #:group "kvm"
+                                             #:environment-variables
+                                             ;; QEMU tries to write to /var/tmp
+                                             ;; by default.
+                                             '("TMPDIR=/tmp")))
+                    (port #$(hurd-vm-port config %hurd-vm-secrets-port))
+                    (root #$(hurd-vm-configuration-secret-root config))
+                    (address (make-socket-address AF_INET INADDR_LOOPBACK
+                                                  port)))
                (catch #t
                  (lambda _
                    ;; XXX: 'secret-service-send-secrets' won't complete until
                    ;; the guest has booted and its secret service server is
                    ;; running, which could take 20+ seconds during which PID 1
                    ;; is stuck waiting.
-                   (if (secret-service-send-secrets port root)
+                   (if (secret-service-send-secrets address root)
                        pid
                        (begin
                          (kill (- pid) SIGTERM)