Commit | Line | Data |
---|---|---|
ec32d4f2 JN |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> | |
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 | (define-module (gnu build secret-service) | |
21 | #:use-module (guix build utils) | |
22 | ||
23 | #:use-module (srfi srfi-26) | |
24 | #:use-module (rnrs bytevectors) | |
25 | #:use-module (ice-9 binary-ports) | |
26 | #:use-module (ice-9 match) | |
27 | #:use-module (ice-9 rdelim) | |
28 | ||
29 | #:export (secret-service-receive-secrets | |
30 | secret-service-send-secrets)) | |
31 | ||
32 | ;;; Commentary: | |
33 | ;;; | |
34 | ;;; Utility procedures for copying secrets into a VM. | |
35 | ;;; | |
36 | ;;; Code: | |
37 | ||
d5366500 LC |
38 | (define-syntax log |
39 | (lambda (s) | |
40 | "Log the given message." | |
41 | (syntax-case s () | |
42 | ((_ fmt args ...) | |
43 | (with-syntax ((fmt (string-append "secret service: " | |
44 | (syntax->datum #'fmt)))) | |
45 | ;; Log to the current output port. That way, when | |
46 | ;; 'secret-service-send-secrets' is called from shepherd, output goes | |
47 | ;; to syslog. | |
48 | #'(format (current-output-port) fmt args ...)))))) | |
49 | ||
59261a22 LC |
50 | (define* (secret-service-send-secrets port secret-root |
51 | #:key (retry 60) | |
52 | (handshake-timeout 120)) | |
ec32d4f2 | 53 | "Copy all files under SECRET-ROOT using TCP to secret-service listening at |
59261a22 LC |
54 | local PORT. If connect fails, sleep 1s and retry RETRY times; once connected, |
55 | wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete. Return | |
56 | #f on failure." | |
ec32d4f2 JN |
57 | (define (file->file+size+mode file-name) |
58 | (let ((stat (stat file-name)) | |
59 | (target (substring file-name (string-length secret-root)))) | |
60 | (list target (stat:size stat) (stat:mode stat)))) | |
61 | ||
59261a22 LC |
62 | (define (send-files sock) |
63 | (let* ((files (if secret-root (find-files secret-root) '())) | |
64 | (files-sizes-modes (map file->file+size+mode files)) | |
65 | (secrets `(secrets | |
66 | (version 0) | |
67 | (files ,files-sizes-modes)))) | |
68 | (write secrets sock) | |
69 | (for-each (lambda (file) | |
70 | (call-with-input-file file | |
71 | (lambda (input) | |
72 | (dump-port input sock)))) | |
73 | files))) | |
74 | ||
d5366500 | 75 | (log "sending secrets to ~a~%" port) |
ec32d4f2 JN |
76 | (let ((sock (socket AF_INET SOCK_STREAM 0)) |
77 | (addr (make-socket-address AF_INET INADDR_LOOPBACK port))) | |
59261a22 LC |
78 | ;; Connect to QEMU on the forwarded port. The 'connect' call succeeds as |
79 | ;; soon as QEMU is ready, even if there's no server listening on the | |
80 | ;; forward port inside the guest. | |
ec32d4f2 JN |
81 | (let loop ((retry retry)) |
82 | (catch 'system-error | |
83 | (cute connect sock addr) | |
84 | (lambda (key . args) | |
85 | (when (zero? retry) | |
86 | (apply throw key args)) | |
d5366500 LC |
87 | (log "retrying connection [~a attempts left]~%" |
88 | (- retry 1)) | |
ec32d4f2 JN |
89 | (sleep 1) |
90 | (loop (1- retry))))) | |
91 | ||
d5366500 | 92 | (log "connected; waiting for handshake...~%") |
59261a22 LC |
93 | |
94 | ;; Wait for "hello" message from the server. This is the only way to know | |
95 | ;; that we're really connected to the server inside the guest. | |
96 | (match (select (list sock) '() '() handshake-timeout) | |
97 | (((_) () ()) | |
98 | (match (read sock) | |
99 | (('secret-service-server ('version version ...)) | |
d5366500 | 100 | (log "sending files from ~s...~%" secret-root) |
59261a22 | 101 | (send-files sock) |
d5366500 | 102 | (log "done sending files to port ~a~%" port) |
59261a22 LC |
103 | (close-port sock) |
104 | secret-root) | |
105 | (x | |
d5366500 | 106 | (log "invalid handshake ~s~%" x) |
59261a22 LC |
107 | (close-port sock) |
108 | #f))) | |
109 | ((() () ()) ;timeout | |
d5366500 | 110 | (log "timeout while sending files to ~a~%" port) |
59261a22 LC |
111 | (close-port sock) |
112 | #f)))) | |
ec32d4f2 JN |
113 | |
114 | (define (secret-service-receive-secrets port) | |
115 | "Listen to local PORT and wait for a secret service client to send secrets. | |
4d047853 LC |
116 | Write them to the file system. Return the list of files installed on success, |
117 | and #f otherwise." | |
ec32d4f2 JN |
118 | |
119 | (define (wait-for-client port) | |
120 | ;; Wait for a TCP connection on PORT. Note: We cannot use the | |
121 | ;; virtio-serial ports, which would be safer, because they are | |
122 | ;; (presumably) unsupported on GNU/Hurd. | |
123 | (let ((sock (socket AF_INET SOCK_STREAM 0))) | |
124 | (bind sock AF_INET INADDR_ANY port) | |
125 | (listen sock 1) | |
d5366500 | 126 | (log "waiting for secrets on port ~a...~%" port) |
4d047853 LC |
127 | (match (select (list sock) '() '() 60) |
128 | (((_) () ()) | |
129 | (match (accept sock) | |
130 | ((client . address) | |
d5366500 LC |
131 | (log "client connection from ~a~%" |
132 | (inet-ntop (sockaddr:fam address) | |
133 | (sockaddr:addr address))) | |
59261a22 LC |
134 | |
135 | ;; Send a "hello" message. This allows the client running on the | |
136 | ;; host to know that it's now actually connected to server running | |
137 | ;; in the guest. | |
138 | (write '(secret-service-server (version 0)) client) | |
139 | (force-output client) | |
4d047853 LC |
140 | (close-port sock) |
141 | client))) | |
142 | ((() () ()) | |
d5366500 | 143 | (log "did not receive any secrets; time out~%") |
59261a22 | 144 | (close-port sock) |
4d047853 | 145 | #f)))) |
ec32d4f2 JN |
146 | |
147 | ;; TODO: Remove when (@ (guix build utils) dump-port) has a 'size' | |
148 | ;; parameter. | |
149 | (define (dump in out size) | |
150 | ;; Copy SIZE bytes from IN to OUT. | |
151 | (define buf-size 65536) | |
152 | (define buf (make-bytevector buf-size)) | |
153 | ||
154 | (let loop ((left size)) | |
155 | (if (<= left 0) | |
156 | 0 | |
157 | (let ((read (get-bytevector-n! in buf 0 (min left buf-size)))) | |
158 | (if (eof-object? read) | |
159 | left | |
160 | (begin | |
161 | (put-bytevector out buf 0 read) | |
162 | (loop (- left read)))))))) | |
163 | ||
164 | (define (read-secrets port) | |
165 | ;; Read secret files from PORT and install them. | |
166 | (match (false-if-exception (read port)) | |
167 | (('secrets ('version 0) | |
168 | ('files ((files sizes modes) ...))) | |
169 | (for-each (lambda (file size mode) | |
d5366500 LC |
170 | (log "installing file '~a' (~a bytes)...~%" |
171 | file size) | |
ec32d4f2 JN |
172 | (mkdir-p (dirname file)) |
173 | (call-with-output-file file | |
174 | (lambda (output) | |
175 | (dump port output size) | |
176 | (chmod file mode)))) | |
4d047853 | 177 | files sizes modes) |
d5366500 | 178 | (log "received ~a secret files~%" (length files)) |
4d047853 | 179 | files) |
ec32d4f2 | 180 | (_ |
d5366500 | 181 | (log "invalid secrets received~%") |
ec32d4f2 JN |
182 | #f))) |
183 | ||
4d047853 LC |
184 | (let* ((port (wait-for-client port)) |
185 | (result (and=> port read-secrets))) | |
186 | (when port | |
187 | (close-port port)) | |
ec32d4f2 JN |
188 | result)) |
189 | ||
190 | ;;; secret-service.scm ends here |