source: project/release/4/openssl/trunk/openssl.scm @ 35554

Last change on this file since 35554 was 35554, checked in by sjamaan, 23 months ago

openssl: Use tcp6 when available

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