M gnu/build/secret-service.scm => gnu/build/secret-service.scm +40 -22
@@ 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))
M gnu/services/virtualization.scm => gnu/services/virtualization.scm +23 -17
@@ 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)