projects/guix·blob python-team · refs

232 lines · 8.9 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2020-2023, 2025 Ludovic Courtès <[email protected]>
3;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20;;; Commentary:
21;;;
22;;; Utility procedures for copying secrets into a VM.
23;;;
24;;; Note: This code runs within the 'shepherd' process, hence the use of
25;;; Fibers.
26;;;
27;;; Code:
28
29(define-module (gnu build secret-service)
30 #:autoload (fibers io-wakeup) (wait-until-port-readable-operation)
31 #:autoload (fibers operations) (perform-operation
32 choice-operation
33 wrap-operation)
34 #:autoload (fibers timers) (sleep-operation)
35 #:use-module (guix build utils)
36 #:use-module (srfi srfi-26)
37 #:use-module (rnrs bytevectors)
38 #:use-module (ice-9 binary-ports)
39 #:use-module (ice-9 match)
40 #:use-module (ice-9 rdelim)
41
42 #:export (secret-service-receive-secrets
43 secret-service-send-secrets))
44
45(define-syntax log
46 (lambda (s)
47 "Log the given message."
48 (syntax-case s ()
49 ((_ fmt args ...)
50 (with-syntax ((fmt (string-append "secret service: "
51 (syntax->datum #'fmt))))
52 ;; Log to the current output port. That way, when
53 ;; 'secret-service-send-secrets' is called from shepherd, output goes
54 ;; to syslog.
55 #'(format (current-output-port) fmt args ...))))))
56
57(define (wait-for-readable-fd port timeout)
58 "Wait until PORT has data available for reading or TIMEOUT has expired.
59Return #t in the former case and #f in the latter case."
60 (perform-operation
61 (choice-operation
62 (wrap-operation (wait-until-port-readable-operation port)
63 (const #t))
64 (wrap-operation (sleep-operation timeout)
65 (const #f)))))
66
67(define (socket-address->string address)
68 "Return a human-readable representation of ADDRESS, an object as returned by
69'make-socket-address'."
70 (let ((family (sockaddr:fam address)))
71 (cond ((= AF_INET family)
72 (string-append (inet-ntop AF_INET (sockaddr:addr address))
73 ":" (number->string (sockaddr:port address))))
74 ((= AF_INET6 family)
75 (string-append "[" (inet-ntop AF_INET6 (sockaddr:addr address)) "]"
76 ":" (number->string (sockaddr:port address))))
77 ((= AF_UNIX family)
78 (sockaddr:path address))
79 (else
80 (object->string address)))))
81
82(define* (secret-service-send-secrets address secret-root
83 #:key (retry 60)
84 (handshake-timeout 180))
85 "Copy all files under SECRET-ROOT by connecting to secret-service listening
86at ADDRESS, an address as returned by 'make-socket-address'. If connection
87fails, sleep 1s and retry RETRY times; once connected, wait for at most
88HANDSHAKE-TIMEOUT seconds for handshake to complete. Return #f on failure."
89 (define (file->file+size+mode file-name)
90 (let ((stat (stat file-name))
91 (target (substring file-name (string-length secret-root))))
92 (list target (stat:size stat) (stat:mode stat))))
93
94 (define (send-files sock)
95 (let* ((files (if secret-root (find-files secret-root) '()))
96 (files-sizes-modes (map file->file+size+mode files))
97 (secrets `(secrets
98 (version 0)
99 (files ,files-sizes-modes))))
100 (write secrets sock)
101 (for-each (lambda (file)
102 (call-with-input-file file
103 (lambda (input)
104 (dump-port input sock))))
105 files)))
106
107 (log "sending secrets to ~a~%" (socket-address->string address))
108
109 (let ((sock (socket AF_INET
110 (logior SOCK_CLOEXEC SOCK_NONBLOCK SOCK_STREAM)
111 0))
112 (sleep (module-ref (resolve-interface '(fibers)) 'sleep)))
113 ;; Connect to QEMU on the forwarded port. The 'connect' call succeeds as
114 ;; soon as QEMU is ready, even if there's no server listening on the
115 ;; forward port inside the guest.
116 (let loop ((retry retry))
117 (catch 'system-error
118 (cute connect sock address)
119 (lambda (key . args)
120 (when (zero? retry)
121 (apply throw key args))
122 (log "retrying connection [~a attempts left]~%"
123 (- retry 1))
124 (sleep 1)
125 (loop (1- retry)))))
126
127 (log "connected; waiting for handshake...~%")
128
129 ;; Wait for "hello" message from the server. This is the only way to know
130 ;; that we're really connected to the server inside the guest.
131 (if (wait-for-readable-fd sock handshake-timeout)
132 (match (read sock)
133 (('secret-service-server ('version version ...))
134 (log "sending files from ~s...~%" secret-root)
135 (send-files sock)
136 (log "done sending files to ~a~%"
137 (socket-address->string address))
138 (close-port sock)
139 secret-root)
140 (x
141 (log "invalid handshake ~s~%" x)
142 (close-port sock)
143 #f))
144 (begin ;timeout
145 (log "timeout while sending files to ~a~%"
146 (socket-address->string address))
147 (close-port sock)
148 #f))))
149
150(define (delete-file* file)
151 "Ensure FILE does not exist."
152 (catch 'system-error
153 (lambda ()
154 (delete-file file))
155 (lambda args
156 (unless (= ENOENT (system-error-errno args))
157 (apply throw args)))))
158
159(define* (secret-service-receive-secrets address
160 #:key (timeout 60))
161 "Listen to ADDRESS, an address returned by 'make-socket-address', and wait
162for a secret service client to send secrets. Write them to the file system.
163Return the list of files installed on success, and #f if TIMEOUT seconds
164passed without receiving any files or if some other failure occurred."
165
166 (define (wait-for-client address)
167 ;; Wait for a connection on ADDRESS. Note: virtio-serial ports are safer
168 ;; than TCP connections but they are (presumably) unsupported on GNU/Hurd.
169 (let ((sock (socket AF_INET
170 (logior SOCK_CLOEXEC SOCK_NONBLOCK SOCK_STREAM)
171 0)))
172 (bind sock address)
173 (listen sock 1)
174 (log "waiting for secrets on ~a...~%"
175 (socket-address->string address))
176
177 (if (wait-for-readable-fd sock timeout)
178 (match (accept sock (logior SOCK_CLOEXEC SOCK_NONBLOCK))
179 ((client . address)
180 (log "client connection from ~a~%"
181 (inet-ntop (sockaddr:fam address)
182 (sockaddr:addr address)))
183
184 ;; Send a "hello" message. This allows the client running on the
185 ;; host to know that it's now actually connected to server running
186 ;; in the guest.
187 (write '(secret-service-server (version 0)) client)
188 (force-output client)
189 (close-port sock)
190 client))
191 (begin
192 (log "did not receive any secrets; time out~%")
193 (close-port sock)
194 #f))))
195
196 (define (read-secrets port)
197 ;; Read secret files from PORT and install them.
198 (match (false-if-exception (read port))
199 (('secrets ('version 0)
200 ('files ((files sizes modes) ...)))
201 (for-each (lambda (file size mode)
202 (log "installing file '~a' (~a bytes)...~%"
203 file size)
204 (mkdir-p (dirname file))
205
206 ;; It could be that FILE already exists, for instance
207 ;; because it has been created by a service's activation
208 ;; snippet (e.g., SSH host keys). Delete it.
209 (delete-file* file)
210
211 (call-with-output-file file
212 (lambda (output)
213 (dump-port port output size)
214 (chmod file mode))))
215 files sizes modes)
216 (log "received ~a secret files~%" (length files))
217 files)
218 (_
219 (log "invalid secrets received~%")
220 #f)))
221
222 (let* ((port (wait-for-client address))
223 (result (and=> port read-secrets)))
224 (when port
225 (close-port port))
226 result))
227
228;;; Local Variables:
229;;; eval: (put 'with-modules 'scheme-indent-function 1)
230;;; End:
231
232;;; secret-service.scm ends here