1 | ;;;; openssl.scm |
---|
2 | ;;;; Bindings to the OpenSSL SSL/TLS library |
---|
3 | |
---|
4 | (module openssl |
---|
5 | ( |
---|
6 | ssl-connect ssl-connect* |
---|
7 | ssl-make-client-context ssl-make-client-context* |
---|
8 | ssl-client-context? |
---|
9 | ssl-listen ssl-listen* |
---|
10 | ssl-start* |
---|
11 | ssl-close |
---|
12 | ssl-port? |
---|
13 | ssl-port->tcp-port |
---|
14 | ssl-listener? |
---|
15 | ssl-listener? |
---|
16 | ssl-listener-port |
---|
17 | ssl-listener-fileno |
---|
18 | ssl-accept-ready? |
---|
19 | ssl-accept |
---|
20 | ssl-handshake-timeout |
---|
21 | ssl-shutdown-timeout |
---|
22 | ssl-set-cipher-list! |
---|
23 | ssl-load-certificate-chain! |
---|
24 | ssl-load-private-key! |
---|
25 | ssl-set-verify! |
---|
26 | ssl-load-verify-root-certificates! |
---|
27 | ssl-load-suggested-certificate-authorities! |
---|
28 | ssl-peer-verified? |
---|
29 | ssl-peer-subject-name ssl-peer-issuer-name |
---|
30 | ssl-default-certificate-authorities |
---|
31 | ssl-default-certificate-authority-directory |
---|
32 | ssl-make-i/o-ports |
---|
33 | net-unwrap-tcp-ports) |
---|
34 | |
---|
35 | (import scheme) |
---|
36 | (import (chicken base)) |
---|
37 | (import (chicken foreign)) |
---|
38 | (import (chicken blob)) |
---|
39 | (import (chicken condition)) |
---|
40 | (import (chicken port)) |
---|
41 | (import (chicken fixnum)) |
---|
42 | (import (chicken gc)) |
---|
43 | (import (chicken string)) |
---|
44 | (import (chicken time)) |
---|
45 | (import (srfi 13)) |
---|
46 | (import (srfi 18)) |
---|
47 | (import (only address-info address-infos)) |
---|
48 | |
---|
49 | (declare |
---|
50 | (usual-integrations) |
---|
51 | (no-procedure-checks-for-usual-bindings) |
---|
52 | (disable-interrupts) |
---|
53 | (bound-to-procedure |
---|
54 | ##sys#update-errno |
---|
55 | ##sys#signal-hook |
---|
56 | ##sys#string-append |
---|
57 | ##sys#tcp-port->fileno |
---|
58 | ##sys#current-thread |
---|
59 | ##sys#size |
---|
60 | ##sys#setslot |
---|
61 | ##sys#check-string)) |
---|
62 | |
---|
63 | #> |
---|
64 | #include <errno.h> |
---|
65 | #ifdef _WIN32 |
---|
66 | #ifdef _MSC_VER |
---|
67 | #include <winsock2.h> |
---|
68 | #else |
---|
69 | #include <ws2tcpip.h> |
---|
70 | #endif |
---|
71 | |
---|
72 | #include <openssl/rand.h> |
---|
73 | #else |
---|
74 | #define closesocket close |
---|
75 | #endif |
---|
76 | |
---|
77 | #ifdef ECOS |
---|
78 | #include <sys/sockio.h> |
---|
79 | #else |
---|
80 | #include <unistd.h> |
---|
81 | #endif |
---|
82 | |
---|
83 | #include <openssl/err.h> |
---|
84 | #include <openssl/ssl.h> |
---|
85 | <# |
---|
86 | |
---|
87 | (foreign-code #<<EOF |
---|
88 | ERR_load_crypto_strings(); |
---|
89 | SSL_load_error_strings(); |
---|
90 | SSL_library_init(); |
---|
91 | |
---|
92 | #ifdef _WIN32 |
---|
93 | RAND_screen(); |
---|
94 | #endif |
---|
95 | |
---|
96 | EOF |
---|
97 | ) |
---|
98 | |
---|
99 | ;;; support routines |
---|
100 | |
---|
101 | (define-foreign-variable strerror c-string "strerror(errno)") |
---|
102 | |
---|
103 | (define ssl-handshake-timeout (make-parameter 120000)) |
---|
104 | (define ssl-shutdown-timeout (make-parameter 120000)) |
---|
105 | |
---|
106 | (define (net-close-socket fd) |
---|
107 | (when ((foreign-lambda bool "closesocket" int) fd) |
---|
108 | (##sys#update-errno) |
---|
109 | (##sys#signal-hook |
---|
110 | network-error: 'net-close-socket |
---|
111 | (##sys#string-append "can not close socket - " strerror) |
---|
112 | fd))) |
---|
113 | |
---|
114 | (define (tcp-port->fileno p loc) |
---|
115 | ;; copied from tcp.scm in core |
---|
116 | (let ((data (##sys#port-data p))) |
---|
117 | (if (vector? data) ; a meagre test, but better than nothing |
---|
118 | (##sys#slot data 0) |
---|
119 | (error loc "argument does not appear to be a TCP port" p)))) |
---|
120 | |
---|
121 | (define (net-unwrap-tcp-ports tcp-in tcp-out) |
---|
122 | (let ((fd (tcp-port->fileno tcp-in 'net-unwrap-tcp-ports))) |
---|
123 | (tcp-abandon-port tcp-in) |
---|
124 | (tcp-abandon-port tcp-out) |
---|
125 | fd)) |
---|
126 | |
---|
127 | (define (ssl-abort loc sym . args) |
---|
128 | (let ((err ((foreign-lambda unsigned-long "ERR_get_error")))) |
---|
129 | (abort |
---|
130 | (make-composite-condition |
---|
131 | (make-property-condition |
---|
132 | 'exn |
---|
133 | 'message |
---|
134 | (string-append |
---|
135 | (if sym |
---|
136 | (symbol->string sym) |
---|
137 | "error") |
---|
138 | ": library=" |
---|
139 | (or |
---|
140 | ((foreign-lambda c-string "ERR_lib_error_string" unsigned-long) |
---|
141 | err) |
---|
142 | "<unknown>") |
---|
143 | ", function=" |
---|
144 | (or |
---|
145 | ((foreign-lambda c-string "ERR_func_error_string" unsigned-long) |
---|
146 | err) |
---|
147 | "<unknown>") |
---|
148 | ", reason=" |
---|
149 | (or |
---|
150 | ((foreign-lambda c-string "ERR_reason_error_string" unsigned-long) |
---|
151 | err) |
---|
152 | "<unknown>")) |
---|
153 | 'location |
---|
154 | loc |
---|
155 | 'arguments args) |
---|
156 | (make-property-condition |
---|
157 | 'i/o) |
---|
158 | (make-property-condition |
---|
159 | 'net) |
---|
160 | (make-property-condition |
---|
161 | 'openssl |
---|
162 | 'status |
---|
163 | sym))))) |
---|
164 | |
---|
165 | (define ssl-clear-error (foreign-lambda void "ERR_clear_error")) |
---|
166 | |
---|
167 | (define ssl-ctx-free (foreign-lambda void "SSL_CTX_free" c-pointer)) |
---|
168 | |
---|
169 | (define (ssl-ctx-new protocol server) |
---|
170 | (ssl-clear-error) |
---|
171 | (let ((ctx |
---|
172 | ((foreign-lambda* |
---|
173 | c-pointer ((c-pointer method)) |
---|
174 | "SSL_CTX *ctx;" |
---|
175 | "if ((ctx = SSL_CTX_new((SSL_METHOD *)method)))\n" |
---|
176 | " SSL_CTX_set_mode(ctx, SSL_MODE_ENABLE_PARTIAL_WRITE | " |
---|
177 | " SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER);\n" |
---|
178 | "return(ctx);\n") |
---|
179 | (case protocol |
---|
180 | ((sslv2-or-v3) |
---|
181 | (if server |
---|
182 | ((foreign-lambda c-pointer "SSLv23_server_method")) |
---|
183 | ((foreign-lambda c-pointer "SSLv23_client_method")))) |
---|
184 | ((sslv3) |
---|
185 | (if server |
---|
186 | ((foreign-lambda c-pointer "SSLv3_server_method")) |
---|
187 | ((foreign-lambda c-pointer "SSLv3_client_method")))) |
---|
188 | ((tls tlsv1) |
---|
189 | (if server |
---|
190 | ((foreign-lambda c-pointer "TLSv1_server_method")) |
---|
191 | ((foreign-lambda c-pointer "TLSv1_client_method")))) |
---|
192 | ((tlsv11) |
---|
193 | (if server |
---|
194 | ((foreign-lambda c-pointer "TLSv1_1_server_method")) |
---|
195 | ((foreign-lambda c-pointer "TLSv1_1_client_method")))) |
---|
196 | ((tlsv12) |
---|
197 | (if server |
---|
198 | ((foreign-lambda c-pointer "TLSv1_2_server_method")) |
---|
199 | ((foreign-lambda c-pointer "TLSv1_2_client_method")))) |
---|
200 | (else |
---|
201 | (abort |
---|
202 | (make-composite-condition |
---|
203 | (make-property-condition |
---|
204 | 'exn |
---|
205 | 'message "invalid SSL/TLS connection protocol" |
---|
206 | 'location 'ssl-ctx-new |
---|
207 | 'arguments (list protocol)) |
---|
208 | (make-property-condition |
---|
209 | 'type)))))))) |
---|
210 | (unless ctx (ssl-abort 'ssl-ctx-new #f)) |
---|
211 | (set-finalizer! ctx ssl-ctx-free) |
---|
212 | ctx)) |
---|
213 | |
---|
214 | (define (ssl-new ctx) |
---|
215 | (ssl-clear-error) |
---|
216 | (cond |
---|
217 | (((foreign-lambda c-pointer "SSL_new" c-pointer) ctx) |
---|
218 | => values) |
---|
219 | (else |
---|
220 | (ssl-abort 'ssl-new #f)))) |
---|
221 | |
---|
222 | (define ssl-free (foreign-lambda void "SSL_free" c-pointer)) |
---|
223 | |
---|
224 | (define (ssl-result-or-abort loc ssl ret allow-i/o? . args) |
---|
225 | (call-with-current-continuation |
---|
226 | (lambda (q) |
---|
227 | (let ((sym |
---|
228 | (let ((x ((foreign-lambda int "SSL_get_error" c-pointer int) |
---|
229 | ssl ret))) |
---|
230 | (cond |
---|
231 | ((eq? x (foreign-value "SSL_ERROR_NONE" int)) |
---|
232 | (q ret)) |
---|
233 | ((eq? x (foreign-value "SSL_ERROR_ZERO_RETURN" int)) |
---|
234 | 'zero-return) |
---|
235 | ((eq? x (foreign-value "SSL_ERROR_WANT_READ" int)) |
---|
236 | (if allow-i/o? |
---|
237 | (q 'want-read) |
---|
238 | 'want-read)) |
---|
239 | ((eq? x (foreign-value "SSL_ERROR_WANT_WRITE" int)) |
---|
240 | (if allow-i/o? |
---|
241 | (q 'want-write) |
---|
242 | 'want-write)) |
---|
243 | ((eq? x (foreign-value "SSL_ERROR_WANT_CONNECT" int)) |
---|
244 | 'want-connect) |
---|
245 | ((eq? x (foreign-value "SSL_ERROR_WANT_ACCEPT" int)) |
---|
246 | 'want-accept) |
---|
247 | ((eq? x (foreign-value "SSL_ERROR_WANT_X509_LOOKUP" int)) |
---|
248 | 'want-X509-lookup) |
---|
249 | ((eq? x (foreign-value "SSL_ERROR_SYSCALL" int)) |
---|
250 | 'syscall) |
---|
251 | ((eq? x (foreign-value "SSL_ERROR_SSL" int)) |
---|
252 | 'ssl) |
---|
253 | (else |
---|
254 | #f))))) |
---|
255 | (apply ssl-abort loc sym args))))) |
---|
256 | |
---|
257 | (define (ssl-set-tlsext-hostname! ssl hostname) |
---|
258 | (ssl-clear-error) |
---|
259 | (ssl-result-or-abort |
---|
260 | 'ssl-set-tlsext-hostname! ssl |
---|
261 | ((foreign-lambda int "SSL_set_tlsext_host_name" c-pointer c-string) |
---|
262 | ssl hostname) #f |
---|
263 | hostname) |
---|
264 | (void)) |
---|
265 | |
---|
266 | (define (ssl-set-fd! ssl fd) |
---|
267 | (ssl-clear-error) |
---|
268 | (ssl-result-or-abort |
---|
269 | 'ssl-set-fd! ssl |
---|
270 | ((foreign-lambda int "SSL_set_fd" c-pointer int) ssl fd) #f |
---|
271 | fd) |
---|
272 | (void)) |
---|
273 | |
---|
274 | (define (ssl-shutdown ssl) |
---|
275 | (ssl-clear-error) |
---|
276 | (let ((ret |
---|
277 | ((foreign-lambda* |
---|
278 | scheme-object ((c-pointer ssl)) |
---|
279 | "int ret;\n" |
---|
280 | "switch (ret = SSL_shutdown((SSL *)ssl)) {\n" |
---|
281 | "case 0: return(C_SCHEME_FALSE);\n" |
---|
282 | "case 1: return(C_SCHEME_TRUE);\n" |
---|
283 | "default: return(C_fix(ret));\n" |
---|
284 | "}\n") ssl))) |
---|
285 | (if (fixnum? ret) |
---|
286 | (ssl-result-or-abort 'ssl-shutdown ssl ret #t) |
---|
287 | ret))) |
---|
288 | |
---|
289 | (define (ssl-read! ssl buffer offset size) |
---|
290 | (ssl-clear-error) |
---|
291 | (let ((ret |
---|
292 | ((foreign-lambda* |
---|
293 | scheme-object ((c-pointer ssl) (scheme-pointer buf) (int offset) (int size)) |
---|
294 | "int ret;\n" |
---|
295 | "switch (ret = SSL_read((SSL *)ssl, (char *)buf + offset, size)) {\n" |
---|
296 | "case 0: return(SSL_get_error((SSL *)ssl, 0) == SSL_ERROR_ZERO_RETURN ?\n" |
---|
297 | " C_SCHEME_END_OF_FILE : C_fix(0));\n" |
---|
298 | "default: return(C_fix(ret));\n" |
---|
299 | "}\n") |
---|
300 | ssl buffer offset size))) |
---|
301 | (cond ((eof-object? ret) 0) |
---|
302 | ((fx> ret 0) ret) |
---|
303 | (else (ssl-result-or-abort 'ssl-read! ssl ret #t))))) |
---|
304 | |
---|
305 | (define (ssl-get-char ssl) |
---|
306 | (ssl-clear-error) |
---|
307 | (let ((ret |
---|
308 | ((foreign-lambda* |
---|
309 | scheme-object ((c-pointer ssl)) |
---|
310 | "unsigned char ch;\n" |
---|
311 | "int ret;\n" |
---|
312 | "switch (ret = SSL_read((SSL *)ssl, &ch, 1)) {\n" |
---|
313 | "case 0: return(SSL_get_error((SSL *)ssl, 0) == SSL_ERROR_ZERO_RETURN ?\n" |
---|
314 | " C_SCHEME_END_OF_FILE : C_fix(0));\n" |
---|
315 | "case 1: return(C_make_character(ch));\n" |
---|
316 | "default: return(C_fix(ret));\n" |
---|
317 | "}\n") |
---|
318 | ssl))) |
---|
319 | (if (fixnum? ret) |
---|
320 | (ssl-result-or-abort 'ssl-get-char ssl ret #t) |
---|
321 | ret))) |
---|
322 | |
---|
323 | (define (ssl-peek-char ssl) |
---|
324 | (ssl-clear-error) |
---|
325 | (let ((ret |
---|
326 | ((foreign-lambda* |
---|
327 | scheme-object ((c-pointer ssl)) |
---|
328 | "unsigned char ch;\n" |
---|
329 | "int ret;\n" |
---|
330 | "switch (ret = SSL_peek((SSL *)ssl, &ch, 1)) {\n" |
---|
331 | "case 0: return(SSL_get_error((SSL *)ssl, 0) == SSL_ERROR_ZERO_RETURN ?\n" |
---|
332 | " C_SCHEME_END_OF_FILE : C_fix(0));\n" |
---|
333 | "case 1: return(C_make_character(ch));\n" |
---|
334 | "default: return(C_fix(ret));\n" |
---|
335 | "}\n") |
---|
336 | ssl))) |
---|
337 | (if (fixnum? ret) |
---|
338 | (ssl-result-or-abort 'ssl-peek-char ssl ret #t) |
---|
339 | ret))) |
---|
340 | |
---|
341 | (define (ssl-write ssl buffer offset size) |
---|
342 | (ssl-clear-error) |
---|
343 | (ssl-result-or-abort |
---|
344 | 'ssl-write ssl |
---|
345 | ((foreign-lambda* |
---|
346 | int ((c-pointer ssl) (scheme-pointer buf) (int offset) (int size)) |
---|
347 | "return(SSL_write((SSL *)ssl, (char *)buf + offset, size));\n") |
---|
348 | ssl buffer offset size) |
---|
349 | #t)) |
---|
350 | |
---|
351 | (define-record-type ssl-port-data |
---|
352 | (ssl-make-port-data startup ssl tcp-port) |
---|
353 | ssl-port-data? |
---|
354 | (startup ssl-port-data-startup) |
---|
355 | (ssl ssl-port-data-ssl) |
---|
356 | (tcp-port ssl-port-data-tcp-port)) |
---|
357 | |
---|
358 | (define (ssl-port? obj) |
---|
359 | (and (port? obj) (eq? (##sys#slot obj 10) 'ssl-socket))) |
---|
360 | |
---|
361 | (define (ssl-port-startup p) |
---|
362 | (when (ssl-port? p) |
---|
363 | ((ssl-port-data-startup (##sys#slot p 11))))) |
---|
364 | |
---|
365 | (define (ssl-port->ssl p) |
---|
366 | (if (ssl-port? p) |
---|
367 | (ssl-port-data-ssl (##sys#slot p 11)) |
---|
368 | (abort |
---|
369 | (make-composite-condition |
---|
370 | (make-property-condition |
---|
371 | 'exn |
---|
372 | 'location 'ssl-port->ssl-context |
---|
373 | 'message "expected an ssl port, got" |
---|
374 | 'arguments (list p)) |
---|
375 | (make-property-condition |
---|
376 | 'type))))) |
---|
377 | |
---|
378 | (define (ssl-port->tcp-port p) |
---|
379 | (if (ssl-port? p) |
---|
380 | (ssl-port-data-tcp-port (##sys#slot p 11)) |
---|
381 | (abort |
---|
382 | (make-composite-condition |
---|
383 | (make-property-condition |
---|
384 | 'exn |
---|
385 | 'location 'ssl-port->tcp-port |
---|
386 | 'message "expected an ssl port, got" |
---|
387 | 'arguments (list p)) |
---|
388 | (make-property-condition |
---|
389 | 'type))))) |
---|
390 | |
---|
391 | (define (ssl-do-handshake ssl) |
---|
392 | (ssl-clear-error) |
---|
393 | (ssl-result-or-abort 'ssl-do-handshake ssl |
---|
394 | ((foreign-lambda int "SSL_do_handshake" c-pointer) ssl) #t)) |
---|
395 | |
---|
396 | (define (ssl-call/timeout loc proc fd timeout timeout-message) |
---|
397 | (let loop ((res (proc))) |
---|
398 | (case res |
---|
399 | ((want-read) |
---|
400 | (when timeout |
---|
401 | (##sys#thread-block-for-timeout! |
---|
402 | ##sys#current-thread (+ (current-milliseconds) timeout))) |
---|
403 | (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input) |
---|
404 | (thread-yield!) |
---|
405 | (if (##sys#slot ##sys#current-thread 13) |
---|
406 | (##sys#signal-hook |
---|
407 | #:network-timeout-error loc timeout-message timeout fd) |
---|
408 | (loop (proc)))) |
---|
409 | ((want-write) |
---|
410 | (when timeout |
---|
411 | (##sys#thread-block-for-timeout! |
---|
412 | ##sys#current-thread (+ (current-milliseconds) timeout))) |
---|
413 | (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output) |
---|
414 | (thread-yield!) |
---|
415 | (if (##sys#slot ##sys#current-thread 13) |
---|
416 | (##sys#signal-hook |
---|
417 | #:network-timeout-error loc timeout-message timeout fd) |
---|
418 | (loop (proc)))) |
---|
419 | (else res)))) |
---|
420 | |
---|
421 | (define (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out) |
---|
422 | ;; note that the ctx parameter is never used but it is passed in order |
---|
423 | ;; to be present in the closure data of the various port functions |
---|
424 | ;; so it isn't garbage collected before the ports are all gone |
---|
425 | (let ((in-open? #f) (out-open? #f) |
---|
426 | (mutex (make-mutex 'ssl-mutex))) |
---|
427 | (define (startup #!optional (called-from-close #f)) |
---|
428 | (dynamic-wind |
---|
429 | (lambda () |
---|
430 | (mutex-lock! mutex)) |
---|
431 | (lambda () |
---|
432 | (let ((skip-startup (not ssl))) |
---|
433 | (if skip-startup |
---|
434 | (when (not called-from-close) |
---|
435 | (error "SSL socket already closed")) |
---|
436 | (unless (or in-open? out-open?) |
---|
437 | (let ((success? #f)) |
---|
438 | (dynamic-wind |
---|
439 | void |
---|
440 | (lambda () |
---|
441 | (ssl-set-fd! ssl fd) |
---|
442 | (ssl-call/timeout 'ssl-do-handshake |
---|
443 | (lambda () (ssl-do-handshake ssl)) |
---|
444 | fd (ssl-handshake-timeout) |
---|
445 | "SSL handshake operation timed out") |
---|
446 | (set! in-open? #t) |
---|
447 | (set! out-open? #t) |
---|
448 | (set! success? #t)) |
---|
449 | (lambda () |
---|
450 | (unless success? |
---|
451 | (ssl-free ssl) |
---|
452 | (set! ssl #f) |
---|
453 | (net-close-socket fd))))))) |
---|
454 | (not skip-startup))) |
---|
455 | (lambda () |
---|
456 | (mutex-unlock! mutex)))) |
---|
457 | (define (shutdown) |
---|
458 | (unless (or in-open? out-open?) |
---|
459 | (set! ctx #f) ;; ensure that this reference is lost |
---|
460 | (dynamic-wind |
---|
461 | void |
---|
462 | (lambda () |
---|
463 | (ssl-call/timeout 'ssl-shutdown |
---|
464 | (lambda () (ssl-shutdown ssl)) |
---|
465 | fd (ssl-shutdown-timeout) |
---|
466 | "SSL shutdown operation timed out")) |
---|
467 | (lambda () |
---|
468 | (ssl-free ssl) |
---|
469 | (net-close-socket fd))))) |
---|
470 | (let ((in |
---|
471 | (make-input-port |
---|
472 | ;; read |
---|
473 | (lambda () |
---|
474 | (startup) |
---|
475 | (ssl-call/timeout 'ssl-get-char |
---|
476 | (lambda () (ssl-get-char ssl)) |
---|
477 | fd (tcp-read-timeout) |
---|
478 | "SSL read timed out")) |
---|
479 | ;; ready? |
---|
480 | (lambda () |
---|
481 | (startup) |
---|
482 | (let ((ret (ssl-peek-char ssl))) |
---|
483 | (case ret |
---|
484 | ((want-read want-write) |
---|
485 | #f) |
---|
486 | (else |
---|
487 | #t)))) |
---|
488 | ;; close |
---|
489 | (lambda () |
---|
490 | (when (startup #t) |
---|
491 | (set! in-open? #f) |
---|
492 | (shutdown))) |
---|
493 | ;; peek |
---|
494 | (lambda () |
---|
495 | (startup) |
---|
496 | (ssl-call/timeout 'ssl-peek-char |
---|
497 | (lambda () (ssl-peek-char ssl)) |
---|
498 | fd (tcp-read-timeout) |
---|
499 | "SSL read timed out")) |
---|
500 | ;; read-string! |
---|
501 | (lambda (port size buf offset) |
---|
502 | (startup) |
---|
503 | (ssl-call/timeout 'ssl-read! |
---|
504 | (lambda () (ssl-read! ssl buf offset size)) |
---|
505 | fd (tcp-read-timeout) |
---|
506 | "SSL read timed out")))) |
---|
507 | (out |
---|
508 | (let* ((outbufmax (tcp-buffer-size)) |
---|
509 | (outbuf (and outbufmax (fx> outbufmax 0) (make-string outbufmax))) |
---|
510 | (outbufsize 0) |
---|
511 | (unbuffered-write |
---|
512 | (lambda (buffer #!optional (offset 0) (size (##sys#size buffer))) |
---|
513 | (when (> size 0) ; Undefined behaviour for 0 bytes! |
---|
514 | (let loop ((offset offset) (size size)) |
---|
515 | (let ((ret (ssl-call/timeout |
---|
516 | 'ssl-write |
---|
517 | (lambda () (ssl-write ssl buffer offset size)) |
---|
518 | fd (tcp-write-timeout) "SSL write timed out"))) |
---|
519 | (when (fx< ret size) ; Partial write |
---|
520 | (loop (fx+ offset ret) (fx- size ret))))))))) |
---|
521 | |
---|
522 | (define (buffered-write data #!optional (start 0)) |
---|
523 | (let* ((size (- (##sys#size data) start)) |
---|
524 | (to-copy (min (- outbufmax outbufsize) size)) |
---|
525 | (left-over (- size to-copy))) |
---|
526 | |
---|
527 | (string-copy! outbuf outbufsize data start (+ start to-copy)) |
---|
528 | (set! outbufsize (+ outbufsize to-copy)) |
---|
529 | |
---|
530 | (if (= outbufsize outbufmax) |
---|
531 | (begin |
---|
532 | (unbuffered-write outbuf) |
---|
533 | (set! outbufsize 0))) |
---|
534 | |
---|
535 | (if (> left-over 0) |
---|
536 | (buffered-write data (+ start to-copy))))) |
---|
537 | |
---|
538 | (make-output-port |
---|
539 | ;; write |
---|
540 | (lambda (buffer) |
---|
541 | (startup) |
---|
542 | (if outbuf |
---|
543 | (buffered-write buffer) |
---|
544 | (unbuffered-write buffer))) |
---|
545 | ;; close |
---|
546 | (lambda () |
---|
547 | (when (startup #t) |
---|
548 | (dynamic-wind |
---|
549 | void |
---|
550 | (lambda () |
---|
551 | (when outbuf |
---|
552 | (unbuffered-write outbuf 0 outbufsize) |
---|
553 | (set! outbufsize 0))) |
---|
554 | (lambda () |
---|
555 | (set! out-open? #f) |
---|
556 | (shutdown))))) |
---|
557 | ;; flush |
---|
558 | (lambda () |
---|
559 | (when outbuf |
---|
560 | (startup) |
---|
561 | (unbuffered-write outbuf 0 outbufsize) |
---|
562 | (set! outbufsize 0))))))) |
---|
563 | (##sys#setslot in 3 "(ssl)") |
---|
564 | (##sys#setslot out 3 "(ssl)") |
---|
565 | ;; first "reserved" slot |
---|
566 | ;; Slot 7 should probably stay 'custom |
---|
567 | (##sys#setslot in 10 'ssl-socket) |
---|
568 | (##sys#setslot out 10 'ssl-socket) |
---|
569 | ;; second "reserved" slot |
---|
570 | (##sys#setslot in 11 (ssl-make-port-data startup ssl tcp-in)) |
---|
571 | (##sys#setslot out 11 (ssl-make-port-data startup ssl tcp-out)) |
---|
572 | (values in out)))) |
---|
573 | |
---|
574 | (define (ssl-unwrap-context obj) |
---|
575 | (cond |
---|
576 | ((ssl-client-context? obj) |
---|
577 | (ssl-unwrap-client-context obj)) |
---|
578 | ((ssl-listener? obj) |
---|
579 | (ssl-unwrap-listener-context obj)) |
---|
580 | (else |
---|
581 | (abort |
---|
582 | (make-composite-condition |
---|
583 | (make-property-condition |
---|
584 | 'exn |
---|
585 | 'location 'ssl-unwrap-context |
---|
586 | 'message "expected an ssl-client-context or ssl-listener, got" |
---|
587 | 'arguments (list obj)) |
---|
588 | (make-property-condition |
---|
589 | 'type)))))) |
---|
590 | |
---|
591 | ;;; exported routines |
---|
592 | |
---|
593 | ;; create SSL client context |
---|
594 | (define-record-type ssl-client-context |
---|
595 | (ssl-wrap-client-context context) |
---|
596 | ssl-client-context? |
---|
597 | (context ssl-unwrap-client-context)) |
---|
598 | |
---|
599 | (define (ssl-make-client-context #!optional (protocol 'sslv2-or-v3)) |
---|
600 | (ssl-wrap-client-context (ssl-ctx-new protocol #f))) |
---|
601 | |
---|
602 | (define ssl-set-connect-state! (foreign-lambda void "SSL_set_connect_state" c-pointer)) |
---|
603 | |
---|
604 | (define (symbolic-host? host port) |
---|
605 | (not (address-infos host #:port port #:type 'tcp #:server? #f #:numeric? #t))) |
---|
606 | |
---|
607 | ;; connect to SSL server |
---|
608 | (define (ssl-connect hostname #!optional port (ctx 'sslv2-or-v3) sni-name) |
---|
609 | (let* ((ctx |
---|
610 | (if (ssl-client-context? ctx) |
---|
611 | (ssl-unwrap-client-context ctx) |
---|
612 | (ssl-ctx-new ctx #f))) |
---|
613 | (ssl (ssl-new ctx)) |
---|
614 | (success? #f)) |
---|
615 | (dynamic-wind |
---|
616 | void |
---|
617 | (lambda () |
---|
618 | (when (eq? sni-name #t) |
---|
619 | (set! sni-name |
---|
620 | (and |
---|
621 | (symbolic-host? hostname port) |
---|
622 | (let ((last (sub1 (string-length hostname)))) |
---|
623 | (if (and (>= last 0) (eqv? (string-ref hostname last) #\.)) |
---|
624 | (substring hostname 0 last) |
---|
625 | hostname))))) |
---|
626 | (when sni-name |
---|
627 | (ssl-set-tlsext-hostname! ssl sni-name)) |
---|
628 | (ssl-set-connect-state! ssl) |
---|
629 | (receive (tcp-in tcp-out) |
---|
630 | (tcp-connect hostname port) |
---|
631 | (receive (ssl-in ssl-out) |
---|
632 | (ssl-make-i/o-ports ctx (net-unwrap-tcp-ports tcp-in tcp-out) ssl tcp-in tcp-out) |
---|
633 | (set! success? #t) |
---|
634 | (values ssl-in ssl-out)))) |
---|
635 | (lambda () |
---|
636 | (unless success? |
---|
637 | (ssl-free ssl) |
---|
638 | (set! ssl #f)))))) |
---|
639 | |
---|
640 | ;; create listener/SSL server context |
---|
641 | (define-record-type ssl-listener |
---|
642 | (ssl-wrap-listener context listener) |
---|
643 | ssl-listener? |
---|
644 | (context ssl-unwrap-listener-context) |
---|
645 | (listener ssl-unwrap-listener)) |
---|
646 | |
---|
647 | ;; Import from tcp6 when available, otherwise fall back to the |
---|
648 | ;; standard tcp library from CHICKEN core. |
---|
649 | (define-values (tcp-listen tcp-listener-fileno tcp-listener-port |
---|
650 | tcp-accept tcp-accept-ready? tcp-close |
---|
651 | tcp-abandon-port tcp-buffer-size tcp-connect |
---|
652 | tcp-read-timeout tcp-write-timeout) |
---|
653 | (handle-exceptions |
---|
654 | exn (let () |
---|
655 | (import (chicken tcp)) |
---|
656 | (values tcp-listen tcp-listener-fileno tcp-listener-port |
---|
657 | tcp-accept tcp-accept-ready? tcp-close |
---|
658 | tcp-abandon-port tcp-buffer-size tcp-connect |
---|
659 | tcp-read-timeout tcp-write-timeout)) |
---|
660 | (eval '(let () |
---|
661 | (import tcp6) |
---|
662 | (values tcp-listen tcp-listener-fileno tcp-listener-port |
---|
663 | tcp-accept tcp-accept-ready? tcp-close |
---|
664 | tcp-abandon-port tcp-buffer-size tcp-connect |
---|
665 | tcp-read-timeout tcp-write-timeout))))) |
---|
666 | |
---|
667 | (define (ssl-listen port #!optional (backlog 4) (hostname #f) (protocol 'sslv2-or-v3)) |
---|
668 | (ssl-wrap-listener |
---|
669 | (ssl-ctx-new protocol #t) |
---|
670 | (tcp-listen port backlog hostname))) |
---|
671 | |
---|
672 | ;; shutdown a SSL server |
---|
673 | (define (ssl-close listener) |
---|
674 | (tcp-close (ssl-unwrap-listener listener))) |
---|
675 | |
---|
676 | ;; return the port number this listener is operating on |
---|
677 | (define (ssl-listener-port listener) |
---|
678 | (tcp-listener-port (ssl-unwrap-listener listener))) |
---|
679 | |
---|
680 | ;; get the underlying socket descriptor number for an SSL listener |
---|
681 | (define (ssl-listener-fileno listener) |
---|
682 | (tcp-listener-fileno (ssl-unwrap-listener listener))) |
---|
683 | |
---|
684 | ;; check whether an incoming connection is pending |
---|
685 | (define (ssl-accept-ready? listener) |
---|
686 | (tcp-accept-ready? (ssl-unwrap-listener listener))) |
---|
687 | |
---|
688 | (define ssl-set-accept-state! (foreign-lambda void "SSL_set_accept_state" c-pointer)) |
---|
689 | |
---|
690 | ;; accept a connection from an SSL listener |
---|
691 | (define (ssl-accept listener) |
---|
692 | (receive (tcp-in tcp-out) |
---|
693 | (tcp-accept (ssl-unwrap-listener listener)) |
---|
694 | (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out)) |
---|
695 | (ctx (ssl-unwrap-listener-context listener)) |
---|
696 | (ssl (ssl-new ctx))) |
---|
697 | (ssl-set-accept-state! ssl) |
---|
698 | (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out)))) |
---|
699 | |
---|
700 | ;; set the list of allowed ciphers |
---|
701 | (define (ssl-set-cipher-list! obj v) |
---|
702 | (ssl-clear-error) |
---|
703 | (unless (eq? |
---|
704 | ((foreign-lambda |
---|
705 | int "SSL_CTX_set_cipher_list" c-pointer c-string) |
---|
706 | (ssl-unwrap-context obj) |
---|
707 | (if (pair? v) |
---|
708 | (string-join (map ->string v) ":") |
---|
709 | (->string v))) |
---|
710 | 1) |
---|
711 | (ssl-abort 'ssl-set-cipher-list! #f v))) |
---|
712 | |
---|
713 | ;; load identifying certificate or certificate chain into SSL context |
---|
714 | (define (ssl-load-certificate-chain! obj pathname/blob #!optional (asn1? #f)) |
---|
715 | (ssl-clear-error) |
---|
716 | (unless |
---|
717 | (eq? |
---|
718 | (if (blob? pathname/blob) |
---|
719 | ((foreign-lambda |
---|
720 | int "SSL_CTX_use_certificate_ASN1" c-pointer int scheme-pointer) |
---|
721 | (ssl-unwrap-context obj) (blob-size pathname/blob) pathname/blob) |
---|
722 | (begin |
---|
723 | (##sys#check-string pathname/blob) |
---|
724 | (if asn1? |
---|
725 | ((foreign-lambda* |
---|
726 | int ((c-pointer ctx) (c-string path)) |
---|
727 | "return(SSL_CTX_use_certificate_file((SSL_CTX *)ctx, path, SSL_FILETYPE_ASN1));") |
---|
728 | (ssl-unwrap-context obj) pathname/blob) |
---|
729 | ((foreign-lambda |
---|
730 | int "SSL_CTX_use_certificate_chain_file" c-pointer c-string) |
---|
731 | (ssl-unwrap-context obj) pathname/blob)))) |
---|
732 | 1) |
---|
733 | (ssl-abort 'ssl-load-certificate-chain! #f pathname/blob asn1?))) |
---|
734 | |
---|
735 | ;; load the private key for the identifying certificate chain |
---|
736 | (define (ssl-load-private-key! obj pathname/blob #!optional (rsa? #t) (asn1? #f)) |
---|
737 | (ssl-clear-error) |
---|
738 | (unless |
---|
739 | (eq? |
---|
740 | (if (blob? pathname/blob) |
---|
741 | ((foreign-lambda |
---|
742 | int "SSL_CTX_use_PrivateKey_ASN1" int c-pointer scheme-pointer long) |
---|
743 | (case rsa? |
---|
744 | ((rsa #t) |
---|
745 | (foreign-value "EVP_PKEY_RSA" int)) |
---|
746 | ((dsa #f) |
---|
747 | (foreign-value "EVP_PKEY_DSA" int)) |
---|
748 | ((dh) |
---|
749 | (foreign-value "EVP_PKEY_DH" int)) |
---|
750 | ((ec) |
---|
751 | (foreign-value "EVP_PKEY_EC" int)) |
---|
752 | (else |
---|
753 | (abort |
---|
754 | (make-composite-condition |
---|
755 | (make-property-condition |
---|
756 | 'exn |
---|
757 | 'message "invalid key type" |
---|
758 | 'location 'ssl-load-private-key! |
---|
759 | 'arguments (list obj pathname/blob rsa? asn1?)) |
---|
760 | (make-property-condition |
---|
761 | 'type))))) |
---|
762 | (ssl-unwrap-context obj) pathname/blob (blob-size pathname/blob)) |
---|
763 | (begin |
---|
764 | (##sys#check-string pathname/blob) |
---|
765 | (if (memq rsa? '(rsa #t)) |
---|
766 | ((foreign-lambda* |
---|
767 | int ((c-pointer ctx) (c-string path) (bool asn1)) |
---|
768 | "return(SSL_CTX_use_RSAPrivateKey_file((SSL_CTX *)ctx, path, (asn1 ? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));") |
---|
769 | (ssl-unwrap-context obj) pathname/blob asn1?) |
---|
770 | ((foreign-lambda* |
---|
771 | int ((c-pointer ctx) (c-string path) (bool asn1)) |
---|
772 | "return(SSL_CTX_use_PrivateKey_file((SSL_CTX *)ctx, path, (asn1 ? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));") |
---|
773 | (ssl-unwrap-context obj) pathname/blob asn1?)))) |
---|
774 | 1) |
---|
775 | (ssl-abort 'ssl-load-private-key! #f pathname/blob rsa? asn1?))) |
---|
776 | |
---|
777 | ;; switch verification of peer on or off |
---|
778 | (define (ssl-set-verify! obj v) |
---|
779 | ((foreign-lambda* |
---|
780 | void |
---|
781 | ((c-pointer ctx) (bool verify)) |
---|
782 | "SSL_CTX_set_verify((SSL_CTX *)ctx," |
---|
783 | " (verify ? SSL_VERIFY_PEER|SSL_VERIFY_FAIL_IF_NO_PEER_CERT" |
---|
784 | " : SSL_VERIFY_NONE), NULL);\n") |
---|
785 | (ssl-unwrap-context obj) v)) |
---|
786 | |
---|
787 | ;; load trusted root certificates into SSL context |
---|
788 | (define (ssl-load-verify-root-certificates! obj pathname #!optional (dirname #f)) |
---|
789 | (if pathname (##sys#check-string pathname)) |
---|
790 | (if dirname (##sys#check-string dirname)) |
---|
791 | (ssl-clear-error) |
---|
792 | (unless (eq? |
---|
793 | ((foreign-lambda |
---|
794 | int "SSL_CTX_load_verify_locations" c-pointer c-string c-string) |
---|
795 | (ssl-unwrap-context obj) |
---|
796 | (if pathname pathname #f) |
---|
797 | (if dirname dirname #f)) |
---|
798 | 1) |
---|
799 | (ssl-abort 'ssl-load-verify-root-certificates! #f pathname dirname))) |
---|
800 | |
---|
801 | ;; load suggested root certificates into SSL context |
---|
802 | (define (ssl-load-suggested-certificate-authorities! obj pathname) |
---|
803 | (##sys#check-string pathname) |
---|
804 | (ssl-clear-error) |
---|
805 | (cond |
---|
806 | (((foreign-lambda c-pointer "SSL_load_client_CA_file" c-string) pathname) |
---|
807 | => (cut |
---|
808 | (foreign-lambda |
---|
809 | void "SSL_CTX_set_client_CA_list" c-pointer c-pointer) |
---|
810 | (ssl-unwrap-context obj) <>)) |
---|
811 | (else |
---|
812 | (ssl-abort 'ssl-load-suggested-certificate-authorities! #f pathname)))) |
---|
813 | |
---|
814 | ;; check whether the connection peer has presented a valid certificate |
---|
815 | (define (ssl-peer-verified? p) |
---|
816 | (ssl-port-startup p) |
---|
817 | (let ((ssl (ssl-port->ssl p))) |
---|
818 | (and ((foreign-lambda* |
---|
819 | bool ((c-pointer ssl)) |
---|
820 | "C_return(SSL_get_verify_result(ssl) == X509_V_OK);") |
---|
821 | ssl) |
---|
822 | ((foreign-lambda* |
---|
823 | bool ((c-pointer ssl)) |
---|
824 | "X509 *crt = SSL_get_peer_certificate(ssl);\n" |
---|
825 | "X509_free(crt);\n" |
---|
826 | "C_return(crt != NULL);\n") |
---|
827 | ssl)))) |
---|
828 | |
---|
829 | ;; obtain the subject name of the connection peer's certificate, if any |
---|
830 | (define (ssl-peer-subject-name p) |
---|
831 | (ssl-port-startup p) |
---|
832 | ((foreign-lambda* |
---|
833 | c-string* ((c-pointer ssl)) |
---|
834 | "X509 *crt = SSL_get_peer_certificate(ssl);\n" |
---|
835 | "if (!crt) C_return(NULL);\n" |
---|
836 | "char *name = X509_NAME_oneline(X509_get_subject_name(crt), NULL, -1);\n" |
---|
837 | "X509_free(crt);\n" |
---|
838 | "C_return(name);") |
---|
839 | (ssl-port->ssl p))) |
---|
840 | |
---|
841 | ;; obtain the issuer name of the connection peer's certificate, if any |
---|
842 | (define (ssl-peer-issuer-name p) |
---|
843 | (ssl-port-startup p) |
---|
844 | ((foreign-lambda* |
---|
845 | c-string* ((c-pointer ssl)) |
---|
846 | "X509 *crt = SSL_get_peer_certificate(ssl);\n" |
---|
847 | "if (!crt) C_return(NULL);\n" |
---|
848 | "char *name = X509_NAME_oneline(X509_get_issuer_name(crt), NULL, -1);\n" |
---|
849 | "X509_free(crt);\n" |
---|
850 | "C_return(name);") |
---|
851 | (ssl-port->ssl p))) |
---|
852 | |
---|
853 | ;;; wrappers with secure defaults |
---|
854 | |
---|
855 | (define ssl-default-certificate-authorities |
---|
856 | (make-parameter |
---|
857 | (cond-expand |
---|
858 | (macosx "/opt/local/etc/openssl/cert.pem") |
---|
859 | (else #f)))) |
---|
860 | |
---|
861 | (define ssl-default-certificate-authority-directory |
---|
862 | (make-parameter |
---|
863 | (cond-expand |
---|
864 | (unix "/etc/ssl/certs") |
---|
865 | (else "certs")))) |
---|
866 | |
---|
867 | (define (ssl-make-client-context* #!key (protocol 'tlsv12) (cipher-list "DEFAULT") certificate private-key (private-key-type 'rsa) private-key-asn1? certificate-authorities certificate-authority-directory (verify? #t)) |
---|
868 | (unless (or certificate-authorities certificate-authority-directory) |
---|
869 | (set! certificate-authority-directory (ssl-default-certificate-authority-directory)) |
---|
870 | (set! certificate-authorities (ssl-default-certificate-authorities))) |
---|
871 | (let ((ctx (ssl-make-client-context protocol))) |
---|
872 | (ssl-set-cipher-list! ctx cipher-list) |
---|
873 | (when certificate |
---|
874 | (ssl-load-certificate-chain! ctx certificate) |
---|
875 | (ssl-load-private-key! ctx private-key private-key-type private-key-asn1?)) |
---|
876 | (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory) |
---|
877 | (ssl-set-verify! ctx verify?) |
---|
878 | ctx)) |
---|
879 | |
---|
880 | (define (ssl-connect* #!rest args #!key hostname port (sni-name #t)) |
---|
881 | (ssl-connect hostname port (apply ssl-make-client-context* args) sni-name)) |
---|
882 | |
---|
883 | (define (ssl-listen* #!key hostname (port 0) (backlog 4) (protocol 'tlsv12) (cipher-list "DEFAULT") certificate private-key (private-key-type 'rsa) private-key-asn1? certificate-authorities certificate-authority-directory (verify? #f)) |
---|
884 | (unless (or certificate-authorities certificate-authority-directory) |
---|
885 | (set! certificate-authorities (ssl-default-certificate-authorities)) |
---|
886 | (set! certificate-authority-directory (ssl-default-certificate-authority-directory))) |
---|
887 | (let ((ear (ssl-listen port backlog hostname protocol))) |
---|
888 | (ssl-set-cipher-list! ear cipher-list) |
---|
889 | (ssl-load-certificate-chain! ear certificate) |
---|
890 | (ssl-load-private-key! ear private-key private-key-type private-key-asn1?) |
---|
891 | (when certificate-authorities |
---|
892 | (ssl-load-suggested-certificate-authorities! ear certificate-authorities)) |
---|
893 | (ssl-load-verify-root-certificates! ear certificate-authorities certificate-authority-directory) |
---|
894 | (ssl-set-verify! ear verify?) |
---|
895 | ear)) |
---|
896 | |
---|
897 | (define (ssl-start* server? tcp-in tcp-out #!key (protocol 'tlsv12) (cipher-list "DEFAULT") certificate private-key (private-key-type 'rsa) private-key-asn1? certificate-authorities certificate-authority-directory (verify? (not server?)) sni-name) |
---|
898 | (unless (or certificate-authorities certificate-authority-directory) |
---|
899 | (set! certificate-authorities (ssl-default-certificate-authorities)) |
---|
900 | (set! certificate-authority-directory (ssl-default-certificate-authority-directory))) |
---|
901 | ;; ssl-wrap-client-context only serves a technical purpose here, |
---|
902 | ;; as the plain context pointer needs to be wrapped somehow. |
---|
903 | (let ((ctx (ssl-wrap-client-context (ssl-ctx-new protocol server?)))) |
---|
904 | (ssl-set-cipher-list! ctx cipher-list) |
---|
905 | (when certificate |
---|
906 | (ssl-load-certificate-chain! ctx certificate) |
---|
907 | (ssl-load-private-key! ctx private-key private-key-type private-key-asn1?)) |
---|
908 | (when certificate-authorities |
---|
909 | (ssl-load-suggested-certificate-authorities! ctx certificate-authorities)) |
---|
910 | (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory) |
---|
911 | (ssl-set-verify! ctx verify?) |
---|
912 | (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out)) |
---|
913 | (ssl (ssl-new (ssl-unwrap-client-context ctx)))) |
---|
914 | (if server? |
---|
915 | (ssl-set-accept-state! ssl) |
---|
916 | (begin |
---|
917 | (when sni-name |
---|
918 | (ssl-set-tlsext-hostname! ssl sni-name)) |
---|
919 | (ssl-set-connect-state! ssl))) |
---|
920 | (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out)))) |
---|
921 | |
---|
922 | ) |
---|