source: project/release/5/openssl/tags/2.0.0/openssl.scm @ 36515

Last change on this file since 36515 was 36515, checked in by wasamasa, 19 months ago

Release 2.0.0

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