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

Last change on this file since 34564 was 34564, checked in by Thomas Chust, 3 years ago

[openssl] Improved block I/O patch thanks to TheLemonMan?

File size: 27.8 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 tcp)
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(define (ssl-listen port #!optional (backlog 4) (hostname #f) (protocol 'sslv2-or-v3))
638  (ssl-wrap-listener
639   (ssl-ctx-new protocol #t)
640   (tcp-listen port backlog hostname)))
641
642;; shutdown a SSL server
643(define (ssl-close listener)
644  (tcp-close (ssl-unwrap-listener listener)))
645
646;; return the port number this listener is operating on
647(define (ssl-listener-port listener)
648  (tcp-listener-port (ssl-unwrap-listener listener)))
649
650;; get the underlying socket descriptor number for an SSL listener
651(define (ssl-listener-fileno listener)
652  (tcp-listener-fileno (ssl-unwrap-listener listener)))
653
654;; check whether an incoming connection is pending
655(define (ssl-accept-ready? listener)
656  (tcp-accept-ready? (ssl-unwrap-listener listener)))
657
658(define ssl-set-accept-state! (foreign-lambda void "SSL_set_accept_state" c-pointer))
659
660;; accept a connection from an SSL listener
661(define (ssl-accept listener)
662  (receive (tcp-in tcp-out)
663    (tcp-accept (ssl-unwrap-listener listener))
664   (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out))
665          (ctx (ssl-unwrap-listener-context listener))
666          (ssl (ssl-new ctx)))
667     (ssl-set-accept-state! ssl)
668     (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out))))
669
670;; set the list of allowed ciphers
671(define (ssl-set-cipher-list! obj v)
672  (ssl-clear-error)
673  (unless (eq?
674           ((foreign-lambda
675             int "SSL_CTX_set_cipher_list" c-pointer c-string)
676            (ssl-unwrap-context obj)
677            (if (pair? v)
678                (string-join (map ->string v) ":")
679                (->string v)))
680           1)
681    (ssl-abort 'ssl-set-cipher-list! #f v)))
682
683;; load identifying certificate or certificate chain into SSL context
684(define (ssl-load-certificate-chain! obj pathname/blob #!optional (asn1? #f))
685  (ssl-clear-error)
686  (unless
687   (eq?
688    (if (blob? pathname/blob)
689        ((foreign-lambda
690          int "SSL_CTX_use_certificate_ASN1" c-pointer int scheme-pointer)
691         (ssl-unwrap-context obj) (blob-size pathname/blob) pathname/blob)
692        (begin
693          (##sys#check-string pathname/blob)
694          (if asn1?
695              ((foreign-lambda*
696                int ((c-pointer ctx) (c-string path))
697                "return(SSL_CTX_use_certificate_file((SSL_CTX *)ctx, path, SSL_FILETYPE_ASN1));")
698               (ssl-unwrap-context obj) pathname/blob)
699              ((foreign-lambda
700                int "SSL_CTX_use_certificate_chain_file" c-pointer c-string)
701               (ssl-unwrap-context obj) pathname/blob))))
702    1)
703   (ssl-abort 'ssl-load-certificate-chain! #f pathname/blob asn1?)))
704
705;; load the private key for the identifying certificate chain
706(define (ssl-load-private-key! obj pathname/blob #!optional (rsa? #t) (asn1? #f))
707  (ssl-clear-error)
708  (unless
709   (eq?
710    (if (blob? pathname/blob)
711        ((foreign-lambda
712          int "SSL_CTX_use_PrivateKey_ASN1" int c-pointer scheme-pointer long)
713         (case rsa?
714           ((rsa #t)
715            (foreign-value "EVP_PKEY_RSA" int))
716           ((dsa #f)
717            (foreign-value "EVP_PKEY_DSA" int))
718           ((dh)
719            (foreign-value "EVP_PKEY_DH" int))
720           ((ec)
721            (foreign-value "EVP_PKEY_EC" int))
722           (else
723            (abort
724             (make-composite-condition
725              (make-property-condition
726               'exn
727               'message "invalid key type"
728               'location 'ssl-load-private-key!
729               'arguments (list obj pathname/blob rsa? asn1?))
730              (make-property-condition
731               'type)))))
732         (ssl-unwrap-context obj) pathname/blob (blob-size pathname/blob))
733        (begin
734          (##sys#check-string pathname/blob)
735          (if (memq rsa? '(rsa #t))
736              ((foreign-lambda*
737                int ((c-pointer ctx) (c-string path) (bool asn1))
738                "return(SSL_CTX_use_RSAPrivateKey_file((SSL_CTX *)ctx, path, (asn1 ? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));")
739               (ssl-unwrap-context obj) pathname/blob asn1?)
740              ((foreign-lambda*
741                int ((c-pointer ctx) (c-string path) (bool asn1))
742                "return(SSL_CTX_use_PrivateKey_file((SSL_CTX *)ctx, path, (asn1 ? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));")
743               (ssl-unwrap-context obj) pathname/blob asn1?))))
744    1)
745   (ssl-abort 'ssl-load-private-key! #f pathname/blob rsa? asn1?)))
746
747;; switch verification of peer on or off
748(define (ssl-set-verify! obj v)
749  ((foreign-lambda*
750    void
751    ((c-pointer ctx) (bool verify))
752    "SSL_CTX_set_verify((SSL_CTX *)ctx,"
753    " (verify ? SSL_VERIFY_PEER|SSL_VERIFY_FAIL_IF_NO_PEER_CERT"
754    " : SSL_VERIFY_NONE), NULL);\n")
755   (ssl-unwrap-context obj) v))
756
757;; load trusted root certificates into SSL context
758(define (ssl-load-verify-root-certificates! obj pathname #!optional (dirname #f))
759  (if pathname (##sys#check-string pathname))
760  (if dirname (##sys#check-string dirname))
761  (ssl-clear-error)
762  (unless (eq?
763           ((foreign-lambda
764             int "SSL_CTX_load_verify_locations" c-pointer c-string c-string)
765            (ssl-unwrap-context obj)
766            (if pathname pathname #f)
767            (if dirname dirname #f))
768           1)
769    (ssl-abort 'ssl-load-verify-root-certificates! #f pathname dirname)))
770
771;; load suggested root certificates into SSL context
772(define (ssl-load-suggested-certificate-authorities! obj pathname)
773  (##sys#check-string pathname)
774  (ssl-clear-error)
775  (cond
776   (((foreign-lambda c-pointer "SSL_load_client_CA_file" c-string) pathname)
777    => (cut
778        (foreign-lambda
779         void "SSL_CTX_set_client_CA_list" c-pointer c-pointer)
780        (ssl-unwrap-context obj) <>))
781   (else
782    (ssl-abort 'ssl-load-suggested-certificate-authorities! #f pathname))))
783
784;; check whether the connection peer has presented a valid certificate
785(define (ssl-peer-verified? p)
786  (ssl-port-startup p)
787  (let ((ssl (ssl-port->ssl p)))
788    (and ((foreign-lambda*
789           bool ((c-pointer ssl))
790           "C_return(SSL_get_verify_result(ssl) == X509_V_OK);")
791          ssl)
792         ((foreign-lambda*
793           bool ((c-pointer ssl))
794           "X509 *crt = SSL_get_peer_certificate(ssl);\n"
795           "X509_free(crt);\n"
796           "C_return(crt != NULL);\n")
797          ssl))))
798
799;; obtain the subject name of the connection peer's certificate, if any
800(define (ssl-peer-subject-name p)
801  (ssl-port-startup p)
802  ((foreign-lambda*
803    c-string* ((c-pointer ssl))
804    "X509 *crt = SSL_get_peer_certificate(ssl);\n"
805    "if (!crt) C_return(NULL);\n"
806    "char *name = X509_NAME_oneline(X509_get_subject_name(crt), NULL, -1);\n"
807    "X509_free(crt);\n"
808    "C_return(name);")
809   (ssl-port->ssl p)))
810
811;; obtain the issuer name of the connection peer's certificate, if any
812(define (ssl-peer-issuer-name p)
813  (ssl-port-startup p)
814  ((foreign-lambda*
815    c-string* ((c-pointer ssl))
816    "X509 *crt = SSL_get_peer_certificate(ssl);\n"
817    "if (!crt) C_return(NULL);\n"
818    "char *name = X509_NAME_oneline(X509_get_issuer_name(crt), NULL, -1);\n"
819    "X509_free(crt);\n"
820    "C_return(name);")
821   (ssl-port->ssl p)))
822
823;;; wrappers with secure defaults
824
825(define ssl-default-certificate-authority-directory
826  (make-parameter
827   (cond-expand
828    (unix "/etc/ssl/certs")
829    (else "certs"))))
830
831(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))
832  (unless (or certificate-authorities certificate-authority-directory)
833    (set! certificate-authority-directory (ssl-default-certificate-authority-directory)))
834  (let ((ctx (ssl-make-client-context protocol)))
835    (ssl-set-cipher-list! ctx cipher-list)
836    (when certificate
837      (ssl-load-certificate-chain! ctx certificate)
838      (ssl-load-private-key! ctx private-key private-key-type private-key-asn1?))
839    (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory)
840    (ssl-set-verify! ctx verify?)
841    ctx))
842
843(define (ssl-connect* #!rest args #!key hostname port (sni-name #t))
844  (ssl-connect hostname port (apply ssl-make-client-context* args) sni-name))
845
846(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))
847  (unless (or certificate-authorities certificate-authority-directory)
848    (set! certificate-authority-directory (ssl-default-certificate-authority-directory)))
849  (let ((ear (ssl-listen port backlog hostname protocol)))
850    (ssl-set-cipher-list! ear cipher-list)
851    (ssl-load-certificate-chain! ear certificate)
852    (ssl-load-private-key! ear private-key private-key-type private-key-asn1?)
853    (when certificate-authorities
854      (ssl-load-suggested-certificate-authorities! ear certificate-authorities))
855    (ssl-load-verify-root-certificates! ear certificate-authorities certificate-authority-directory)
856    (ssl-set-verify! ear verify?)
857    ear))
858
859(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)
860  (unless (or certificate-authorities certificate-authority-directory)
861    (set! certificate-authority-directory (ssl-default-certificate-authority-directory)))
862  ;; ssl-wrap-client-context only serves a technical purpose here,
863  ;; as the plain context pointer needs to be wrapped somehow.
864  (let ((ctx (ssl-wrap-client-context (ssl-ctx-new protocol server?))))
865    (ssl-set-cipher-list! ctx cipher-list)
866    (when certificate
867      (ssl-load-certificate-chain! ctx certificate)
868      (ssl-load-private-key! ctx private-key private-key-type private-key-asn1?))
869    (when certificate-authorities
870      (ssl-load-suggested-certificate-authorities! ctx certificate-authorities))
871    (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory)
872    (ssl-set-verify! ctx verify?)
873    (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out))
874           (ssl (ssl-new (ssl-unwrap-client-context ctx))))
875      (if server?
876        (ssl-set-accept-state! ssl)
877        (begin
878          (when sni-name
879            (ssl-set-tlsext-hostname! ssl sni-name))
880          (ssl-set-connect-state! ssl)))
881      (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out))))
882
883)
Note: See TracBrowser for help on using the repository browser.