source: project/release/5/openssl/trunk/openssl.scm @ 36536

Last change on this file since 36536 was 36536, checked in by wasamasa, 7 weeks ago

Wrap tcp6 import into eval again

File size: 30.1 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-authorities
31   ssl-default-certificate-authority-directory
32   ssl-make-i/o-ports
33   net-unwrap-tcp-ports)
34
35(import scheme) ; C4 hack for cond-expand
36
37(cond-expand
38 (chicken-4
39  (import scheme chicken foreign ports)
40  (use srfi-13 srfi-18)
41  (import
42   (only data-structures ->string)
43   (only files make-pathname)
44   (only address-info address-infos))
45  (require-library
46   data-structures address-info))
47
48 (chicken-5
49  (import scheme)
50  (import (chicken base))
51  (import (chicken foreign))
52  (import (chicken blob))
53  (import (chicken condition))
54  (import (chicken port))
55  (import (chicken fixnum))
56  (import (chicken gc))
57  (import (chicken string))
58  (import (chicken time))
59  (import (srfi 13))
60  (import (srfi 18))
61  (import (only address-info address-infos))))
62
63(declare
64 (usual-integrations)
65 (no-procedure-checks-for-usual-bindings)
66 (disable-interrupts)
67 (bound-to-procedure
68   ##sys#update-errno
69   ##sys#signal-hook
70   ##sys#string-append
71   ##sys#tcp-port->fileno
72   ##sys#current-thread
73   ##sys#size
74   ##sys#setslot
75   ##sys#check-string))
76
77#>
78#include <errno.h>
79#ifdef _WIN32
80  #ifdef _MSC_VER
81    #include <winsock2.h>
82  #else
83    #include <ws2tcpip.h>
84  #endif
85
86  #include <openssl/rand.h>
87#else
88  #define closesocket     close
89#endif
90
91#ifdef ECOS
92  #include <sys/sockio.h>
93#else
94  #include <unistd.h>
95#endif
96
97#include <openssl/err.h>
98#include <openssl/ssl.h>
99<#
100
101(foreign-code #<<EOF
102ERR_load_crypto_strings();
103SSL_load_error_strings();
104SSL_library_init();
105
106#ifdef _WIN32
107  RAND_screen();
108#endif
109
110EOF
111)
112
113;;; support routines
114
115(define-foreign-variable strerror c-string "strerror(errno)")
116
117(define ssl-handshake-timeout (make-parameter 120000))
118(define ssl-shutdown-timeout (make-parameter 120000))
119
120(define (net-close-socket fd)
121  (when ((foreign-lambda bool "closesocket" int) fd)
122    (##sys#update-errno)
123    (##sys#signal-hook
124     network-error: 'net-close-socket
125     (##sys#string-append "can not close socket - " strerror)
126     fd)))
127
128(define (tcp-port->fileno p loc)
129  (cond-expand
130   (chicken-4
131    (##sys#tcp-port->fileno p))
132
133   (chicken-5
134    ;; copied from tcp.scm in core
135    (let ((data (##sys#port-data p)))
136      (if (vector? data) ; a meagre test, but better than nothing
137          (##sys#slot data 0)
138          (error loc "argument does not appear to be a TCP port" p))))))
139
140(define (net-unwrap-tcp-ports tcp-in tcp-out)
141  (let ((fd (tcp-port->fileno tcp-in 'net-unwrap-tcp-ports)))
142    (tcp-abandon-port tcp-in)
143    (tcp-abandon-port tcp-out)
144    fd))
145
146(define (ssl-abort loc sym . args)
147  (let ((err ((foreign-lambda unsigned-long "ERR_get_error"))))
148    (abort
149     (make-composite-condition
150      (make-property-condition
151       'exn
152       'message
153       (string-append
154        (if sym
155            (symbol->string sym)
156            "error")
157        ": library="
158        (or
159         ((foreign-lambda c-string "ERR_lib_error_string" unsigned-long)
160          err)
161         "<unknown>")
162        ", function="
163        (or
164         ((foreign-lambda c-string "ERR_func_error_string" unsigned-long)
165          err)
166         "<unknown>")
167        ", reason="
168        (or
169         ((foreign-lambda c-string "ERR_reason_error_string" unsigned-long)
170          err)
171         "<unknown>"))
172       'location
173       loc
174       'arguments args)
175      (make-property-condition
176       'i/o)
177      (make-property-condition
178       'net)
179      (make-property-condition
180       'openssl
181       'status
182       sym)))))
183
184(define ssl-clear-error (foreign-lambda void "ERR_clear_error"))
185
186(define ssl-ctx-free (foreign-lambda void "SSL_CTX_free" c-pointer))
187
188(define (ssl-ctx-new protocol server)
189  (ssl-clear-error)
190  (let ((ctx
191         ((foreign-lambda*
192           c-pointer ((c-pointer method))
193           "SSL_CTX *ctx;"
194           "if ((ctx = SSL_CTX_new((SSL_METHOD *)method)))\n"
195           "  SSL_CTX_set_mode(ctx, SSL_MODE_ENABLE_PARTIAL_WRITE | "
196           "                        SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER);\n"
197           "return(ctx);\n")
198          (case protocol
199            ((sslv2-or-v3)
200             (if server
201                 ((foreign-lambda c-pointer "SSLv23_server_method"))
202                 ((foreign-lambda c-pointer "SSLv23_client_method"))))
203            ((sslv3)
204             (if server
205                 ((foreign-lambda c-pointer "SSLv3_server_method"))
206                 ((foreign-lambda c-pointer "SSLv3_client_method"))))
207            ((tls tlsv1)
208             (if server
209                 ((foreign-lambda c-pointer "TLSv1_server_method"))
210                 ((foreign-lambda c-pointer "TLSv1_client_method"))))
211            ((tlsv11)
212             (if server
213                 ((foreign-lambda c-pointer "TLSv1_1_server_method"))
214                 ((foreign-lambda c-pointer "TLSv1_1_client_method"))))
215            ((tlsv12)
216             (if server
217                 ((foreign-lambda c-pointer "TLSv1_2_server_method"))
218                 ((foreign-lambda c-pointer "TLSv1_2_client_method"))))
219            (else
220             (abort
221              (make-composite-condition
222               (make-property-condition
223                'exn
224                'message "invalid SSL/TLS connection protocol"
225                'location 'ssl-ctx-new
226                'arguments (list protocol))
227               (make-property-condition
228                'type))))))))
229    (unless ctx (ssl-abort 'ssl-ctx-new #f))
230    (set-finalizer! ctx ssl-ctx-free)
231    ctx))
232
233(define (ssl-new ctx)
234  (ssl-clear-error)
235  (cond
236   (((foreign-lambda c-pointer "SSL_new" c-pointer) ctx)
237    => values)
238   (else
239    (ssl-abort 'ssl-new #f))))
240
241(define ssl-free (foreign-lambda void "SSL_free" c-pointer))
242
243(define (ssl-result-or-abort loc ssl ret allow-i/o? . args)
244  (call-with-current-continuation
245   (lambda (q)
246     (let ((sym
247            (let ((x ((foreign-lambda int "SSL_get_error" c-pointer int)
248                      ssl ret)))
249              (cond
250               ((eq? x (foreign-value "SSL_ERROR_NONE" int))
251                (q ret))
252               ((eq? x (foreign-value "SSL_ERROR_ZERO_RETURN" int))
253                'zero-return)
254               ((eq? x (foreign-value "SSL_ERROR_WANT_READ" int))
255                (if allow-i/o?
256                    (q 'want-read)
257                    'want-read))
258               ((eq? x (foreign-value "SSL_ERROR_WANT_WRITE" int))
259                (if allow-i/o?
260                    (q 'want-write)
261                    'want-write))
262               ((eq? x (foreign-value "SSL_ERROR_WANT_CONNECT" int))
263                'want-connect)
264               ((eq? x (foreign-value "SSL_ERROR_WANT_ACCEPT" int))
265                'want-accept)
266               ((eq? x (foreign-value "SSL_ERROR_WANT_X509_LOOKUP" int))
267                'want-X509-lookup)
268               ((eq? x (foreign-value "SSL_ERROR_SYSCALL" int))
269                'syscall)
270               ((eq? x (foreign-value "SSL_ERROR_SSL" int))
271                'ssl)
272               (else
273                #f)))))
274       (apply ssl-abort loc sym args)))))
275
276(define (ssl-set-tlsext-hostname! ssl hostname)
277  (ssl-clear-error)
278  (ssl-result-or-abort
279   'ssl-set-tlsext-hostname! ssl
280   ((foreign-lambda int "SSL_set_tlsext_host_name" c-pointer c-string)
281    ssl hostname) #f
282   hostname)
283  (void))
284
285(define (ssl-set-fd! ssl fd)
286  (ssl-clear-error)
287  (ssl-result-or-abort
288   'ssl-set-fd! ssl
289   ((foreign-lambda int "SSL_set_fd" c-pointer int) ssl fd) #f
290   fd)
291  (void))
292
293(define (ssl-shutdown ssl)
294  (ssl-clear-error)
295  (let ((ret
296         ((foreign-lambda*
297           scheme-object ((c-pointer ssl))
298           "int ret;\n"
299           "switch (ret = SSL_shutdown((SSL *)ssl)) {\n"
300           "case 0: return(C_SCHEME_FALSE);\n"
301           "case 1: return(C_SCHEME_TRUE);\n"
302           "default: return(C_fix(ret));\n"
303           "}\n") ssl)))
304    (if (fixnum? ret)
305        (ssl-result-or-abort 'ssl-shutdown ssl ret #t)
306        ret)))
307
308(define (ssl-read! ssl buffer offset size)
309  (ssl-clear-error)
310  (let ((ret
311          ((foreign-lambda*
312             scheme-object ((c-pointer ssl) (scheme-pointer buf) (int offset) (int size))
313             "int ret;\n"
314             "switch (ret = SSL_read((SSL *)ssl, (char *)buf + offset, size)) {\n"
315             "case 0: return(SSL_get_error((SSL *)ssl, 0) == SSL_ERROR_ZERO_RETURN ?\n"
316             "               C_SCHEME_END_OF_FILE : C_fix(0));\n"
317             "default: return(C_fix(ret));\n"
318             "}\n")
319             ssl buffer offset size)))
320    (cond ((eof-object? ret) 0)
321          ((fx> ret 0) ret)
322          (else (ssl-result-or-abort 'ssl-read! ssl ret #t)))))
323
324(define (ssl-get-char ssl)
325  (ssl-clear-error)
326  (let ((ret
327         ((foreign-lambda*
328           scheme-object ((c-pointer ssl))
329           "unsigned char ch;\n"
330           "int ret;\n"
331           "switch (ret = SSL_read((SSL *)ssl, &ch, 1)) {\n"
332           "case 0: return(SSL_get_error((SSL *)ssl, 0) == SSL_ERROR_ZERO_RETURN ?\n"
333           "               C_SCHEME_END_OF_FILE : C_fix(0));\n"
334           "case 1: return(C_make_character(ch));\n"
335           "default: return(C_fix(ret));\n"
336           "}\n")
337          ssl)))
338    (if (fixnum? ret)
339        (ssl-result-or-abort 'ssl-get-char ssl ret #t)
340        ret)))
341
342(define (ssl-peek-char ssl)
343  (ssl-clear-error)
344  (let ((ret
345         ((foreign-lambda*
346           scheme-object ((c-pointer ssl))
347           "unsigned char ch;\n"
348           "int ret;\n"
349           "switch (ret = SSL_peek((SSL *)ssl, &ch, 1)) {\n"
350           "case 0: return(SSL_get_error((SSL *)ssl, 0) == SSL_ERROR_ZERO_RETURN ?\n"
351           "               C_SCHEME_END_OF_FILE : C_fix(0));\n"
352           "case 1: return(C_make_character(ch));\n"
353           "default: return(C_fix(ret));\n"
354           "}\n")
355          ssl)))
356    (if (fixnum? ret)
357        (ssl-result-or-abort 'ssl-peek-char ssl ret #t)
358        ret)))
359
360(define (ssl-write ssl buffer offset size)
361  (ssl-clear-error)
362  (ssl-result-or-abort
363   'ssl-write ssl
364   ((foreign-lambda*
365     int ((c-pointer ssl) (scheme-pointer buf) (int offset) (int size))
366     "return(SSL_write((SSL *)ssl, (char *)buf + offset, size));\n")
367    ssl buffer offset size)
368   #t))
369
370(define-record-type ssl-port-data
371  (ssl-make-port-data startup ssl tcp-port)
372  ssl-port-data?
373  (startup ssl-port-data-startup)
374  (ssl ssl-port-data-ssl)
375  (tcp-port ssl-port-data-tcp-port))
376
377(define (ssl-port? obj)
378  (and (port? obj) (eq? (##sys#slot obj 10) 'ssl-socket)))
379
380(define (ssl-port-startup p)
381  (when (ssl-port? p)
382    ((ssl-port-data-startup (##sys#slot p 11)))))
383
384(define (ssl-port->ssl p)
385  (if (ssl-port? p)
386      (ssl-port-data-ssl (##sys#slot p 11))
387      (abort
388       (make-composite-condition
389        (make-property-condition
390         'exn
391         'location 'ssl-port->ssl-context
392         'message "expected an ssl port, got"
393         'arguments (list p))
394        (make-property-condition
395         'type)))))
396
397(define (ssl-port->tcp-port p)
398  (if (ssl-port? p)
399      (ssl-port-data-tcp-port (##sys#slot p 11))
400      (abort
401       (make-composite-condition
402        (make-property-condition
403         'exn
404         'location 'ssl-port->tcp-port
405         'message "expected an ssl port, got"
406         'arguments (list p))
407        (make-property-condition
408         'type)))))
409
410(define (ssl-do-handshake ssl)
411  (ssl-clear-error)
412  (ssl-result-or-abort 'ssl-do-handshake ssl
413                       ((foreign-lambda int "SSL_do_handshake" c-pointer) ssl) #t))
414
415(define (ssl-call/timeout loc proc fd timeout timeout-message)
416  (let loop ((res (proc)))
417    (case res
418      ((want-read)
419       (when timeout
420         (##sys#thread-block-for-timeout!
421          ##sys#current-thread (+ (current-milliseconds) timeout)))
422       (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
423       (thread-yield!)
424       (if (##sys#slot ##sys#current-thread 13)
425           (##sys#signal-hook
426            #:network-timeout-error loc timeout-message timeout fd)
427           (loop (proc))))
428      ((want-write)
429       (when timeout
430             (##sys#thread-block-for-timeout!
431              ##sys#current-thread (+ (current-milliseconds) timeout)))
432       (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
433       (thread-yield!)
434       (if (##sys#slot ##sys#current-thread 13)
435           (##sys#signal-hook
436            #:network-timeout-error loc timeout-message timeout fd)
437           (loop (proc))))
438      (else res))))
439
440(define (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out)
441  ;; note that the ctx parameter is never used but it is passed in order
442  ;; to be present in the closure data of the various port functions
443  ;; so it isn't garbage collected before the ports are all gone
444  (let ((in-open? #f) (out-open? #f)
445        (mutex (make-mutex 'ssl-mutex)))
446    (define (startup #!optional (called-from-close #f))
447      (dynamic-wind
448          (lambda ()
449            (mutex-lock! mutex))
450          (lambda ()
451           (let ((skip-startup (not ssl)))
452             (if skip-startup
453               (when (not called-from-close)
454                 (error "SSL socket already closed"))
455               (unless (or in-open? out-open?)
456                 (let ((success? #f))
457                   (dynamic-wind
458                     void
459                     (lambda ()
460                       (ssl-set-fd! ssl fd)
461                       (ssl-call/timeout 'ssl-do-handshake
462                                         (lambda () (ssl-do-handshake ssl))
463                                         fd (ssl-handshake-timeout)
464                                         "SSL handshake operation timed out")
465                       (set! in-open? #t)
466                       (set! out-open? #t)
467                       (set! success? #t))
468                     (lambda ()
469                       (unless success?
470                         (ssl-free ssl)
471                         (set! ssl #f)
472                         (net-close-socket fd)))))))
473             (not skip-startup)))
474          (lambda ()
475            (mutex-unlock! mutex))))
476    (define (shutdown)
477      (unless (or in-open? out-open?)
478        (set! ctx #f) ;; ensure that this reference is lost
479        (dynamic-wind
480            void
481            (lambda ()
482              (ssl-call/timeout 'ssl-shutdown
483                                (lambda () (ssl-shutdown ssl))
484                                fd (ssl-shutdown-timeout)
485                                "SSL shutdown operation timed out"))
486            (lambda ()
487              (ssl-free ssl)
488              (net-close-socket fd)))))
489    (let ((in
490            (make-input-port
491              ;; read
492              (lambda ()
493                (startup)
494                (ssl-call/timeout 'ssl-get-char
495                                  (lambda () (ssl-get-char ssl))
496                                  fd (tcp-read-timeout)
497                                  "SSL read timed out"))
498              ;; ready?
499              (lambda ()
500                (startup)
501                (let ((ret (ssl-peek-char ssl)))
502                  (case ret
503                    ((want-read want-write)
504                     #f)
505                    (else
506                      #t))))
507              ;; close
508              (lambda ()
509                (when (startup #t)
510                  (set! in-open? #f)
511                  (shutdown)))
512              ;; peek
513              (lambda ()
514                (startup)
515                (ssl-call/timeout 'ssl-peek-char
516                                  (lambda () (ssl-peek-char ssl))
517                                  fd (tcp-read-timeout)
518                                  "SSL read timed out"))
519              ;; read-string!
520              (lambda (port size buf offset)
521                (startup)
522                (ssl-call/timeout 'ssl-read!
523                                  (lambda () (ssl-read! ssl buf offset size))
524                                  fd (tcp-read-timeout)
525                                  "SSL read timed out"))))
526    (out
527      (let* ((outbufmax  (tcp-buffer-size))
528             (outbuf     (and outbufmax (fx> outbufmax 0) (make-string outbufmax)))
529             (outbufsize 0)
530             (unbuffered-write
531              (lambda (buffer #!optional (offset 0) (size (##sys#size buffer)))
532                (when (> size 0) ; Undefined behaviour for 0 bytes!
533                  (let loop ((offset offset) (size size))
534                    (let ((ret (ssl-call/timeout
535                                'ssl-write
536                                (lambda () (ssl-write ssl buffer offset size))
537                                fd (tcp-write-timeout) "SSL write timed out")))
538                      (when (fx< ret size) ; Partial write
539                        (loop (fx+ offset ret) (fx- size ret)))))))))
540
541        (define (buffered-write data #!optional (start 0))
542          (let* ((size      (- (##sys#size data) start))
543                 (to-copy   (min (- outbufmax outbufsize) size))
544                 (left-over (- size to-copy)))
545
546            (string-copy! outbuf outbufsize data start (+ start to-copy))
547            (set! outbufsize (+ outbufsize to-copy))
548
549            (if (= outbufsize outbufmax)
550              (begin
551                (unbuffered-write outbuf)
552                (set! outbufsize 0)))
553
554            (if (> left-over 0)
555              (buffered-write data (+ start to-copy)))))
556
557        (make-output-port
558         ;; write
559         (lambda (buffer)
560           (startup)
561           (if outbuf
562             (buffered-write buffer)
563             (unbuffered-write buffer)))
564         ;; close
565         (lambda ()
566           (when (startup #t)
567             (dynamic-wind
568               void
569               (lambda ()
570                 (when outbuf
571                   (unbuffered-write outbuf 0 outbufsize)
572                   (set! outbufsize 0)))
573               (lambda ()
574                 (set! out-open? #f)
575                 (shutdown)))))
576         ;; flush
577         (lambda ()
578           (when outbuf
579             (startup)
580             (unbuffered-write outbuf 0 outbufsize)
581             (set! outbufsize 0)))))))
582      (##sys#setslot in 3 "(ssl)")
583      (##sys#setslot out 3 "(ssl)")
584      ;; first "reserved" slot
585      ;; Slot 7 should probably stay 'custom
586      (##sys#setslot in 10 'ssl-socket)
587      (##sys#setslot out 10 'ssl-socket)
588      ;; second "reserved" slot
589      (##sys#setslot in 11 (ssl-make-port-data startup ssl tcp-in))
590      (##sys#setslot out 11 (ssl-make-port-data startup ssl tcp-out))
591      (values in out))))
592
593(define (ssl-unwrap-context obj)
594  (cond
595   ((ssl-client-context? obj)
596    (ssl-unwrap-client-context obj))
597   ((ssl-listener? obj)
598    (ssl-unwrap-listener-context obj))
599   (else
600    (abort
601     (make-composite-condition
602      (make-property-condition
603       'exn
604       'location 'ssl-unwrap-context
605       'message "expected an ssl-client-context or ssl-listener, got"
606       'arguments (list obj))
607      (make-property-condition
608       'type))))))
609
610;;; exported routines
611
612;; create SSL client context
613(define-record-type ssl-client-context
614  (ssl-wrap-client-context context)
615  ssl-client-context?
616  (context ssl-unwrap-client-context))
617
618(define (ssl-make-client-context #!optional (protocol 'sslv2-or-v3))
619  (ssl-wrap-client-context (ssl-ctx-new protocol #f)))
620
621(define ssl-set-connect-state! (foreign-lambda void "SSL_set_connect_state" c-pointer))
622
623(define (symbolic-host? host port)
624  (not (address-infos host #:port port #:type 'tcp #:server? #f #:numeric? #t)))
625
626;; connect to SSL server
627(define (ssl-connect hostname #!optional port (ctx 'sslv2-or-v3) sni-name)
628  (let* ((ctx
629          (if (ssl-client-context? ctx)
630              (ssl-unwrap-client-context ctx)
631              (ssl-ctx-new ctx #f)))
632         (ssl (ssl-new ctx))
633         (success? #f))
634    (dynamic-wind
635      void
636      (lambda ()
637        (when (eq? sni-name #t)
638          (set! sni-name
639            (and
640              (symbolic-host? hostname port)
641              (let ((last (sub1 (string-length hostname))))
642                (if (and (>= last 0) (eqv? (string-ref hostname last) #\.))
643                  (substring hostname 0 last)
644                  hostname)))))
645        (when sni-name
646          (ssl-set-tlsext-hostname! ssl sni-name))
647        (ssl-set-connect-state! ssl)
648        (receive (tcp-in tcp-out)
649          (tcp-connect hostname port)
650          (receive (ssl-in ssl-out)
651            (ssl-make-i/o-ports ctx (net-unwrap-tcp-ports tcp-in tcp-out) ssl tcp-in tcp-out)
652            (set! success? #t)
653            (values ssl-in ssl-out))))
654      (lambda ()
655        (unless success?
656          (ssl-free ssl)
657          (set! ssl #f))))))
658
659;; create listener/SSL server context
660(define-record-type ssl-listener
661  (ssl-wrap-listener context listener)
662  ssl-listener?
663  (context ssl-unwrap-listener-context)
664  (listener ssl-unwrap-listener))
665
666;; Import from tcp6 when available, otherwise fall back to the
667;; standard tcp library from CHICKEN core.
668(define-values (tcp-listen tcp-listener-fileno tcp-listener-port
669                           tcp-accept tcp-accept-ready? tcp-close
670                           tcp-abandon-port tcp-buffer-size tcp-connect
671                           tcp-read-timeout tcp-write-timeout)
672  (handle-exceptions
673   exn (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-authorities
883  (make-parameter
884   (cond-expand
885    (macosx "/opt/local/etc/openssl/cert.pem")
886    (else #f))))
887
888(define ssl-default-certificate-authority-directory
889  (make-parameter
890   (cond-expand
891    (unix "/etc/ssl/certs")
892    (else "certs"))))
893
894(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))
895  (unless (or certificate-authorities certificate-authority-directory)
896    (set! certificate-authority-directory (ssl-default-certificate-authority-directory))
897    (set! certificate-authorities (ssl-default-certificate-authorities)))
898  (let ((ctx (ssl-make-client-context protocol)))
899    (ssl-set-cipher-list! ctx cipher-list)
900    (when certificate
901      (ssl-load-certificate-chain! ctx certificate)
902      (ssl-load-private-key! ctx private-key private-key-type private-key-asn1?))
903    (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory)
904    (ssl-set-verify! ctx verify?)
905    ctx))
906
907(define (ssl-connect* #!rest args #!key hostname port (sni-name #t))
908  (ssl-connect hostname port (apply ssl-make-client-context* args) sni-name))
909
910(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))
911  (unless (or certificate-authorities certificate-authority-directory)
912    (set! certificate-authorities (ssl-default-certificate-authorities))
913    (set! certificate-authority-directory (ssl-default-certificate-authority-directory)))
914  (let ((ear (ssl-listen port backlog hostname protocol)))
915    (ssl-set-cipher-list! ear cipher-list)
916    (ssl-load-certificate-chain! ear certificate)
917    (ssl-load-private-key! ear private-key private-key-type private-key-asn1?)
918    (when certificate-authorities
919      (ssl-load-suggested-certificate-authorities! ear certificate-authorities))
920    (ssl-load-verify-root-certificates! ear certificate-authorities certificate-authority-directory)
921    (ssl-set-verify! ear verify?)
922    ear))
923
924(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)
925  (unless (or certificate-authorities certificate-authority-directory)
926    (set! certificate-authorities (ssl-default-certificate-authorities))
927    (set! certificate-authority-directory (ssl-default-certificate-authority-directory)))
928  ;; ssl-wrap-client-context only serves a technical purpose here,
929  ;; as the plain context pointer needs to be wrapped somehow.
930  (let ((ctx (ssl-wrap-client-context (ssl-ctx-new protocol server?))))
931    (ssl-set-cipher-list! ctx cipher-list)
932    (when certificate
933      (ssl-load-certificate-chain! ctx certificate)
934      (ssl-load-private-key! ctx private-key private-key-type private-key-asn1?))
935    (when certificate-authorities
936      (ssl-load-suggested-certificate-authorities! ctx certificate-authorities))
937    (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory)
938    (ssl-set-verify! ctx verify?)
939    (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out))
940           (ssl (ssl-new (ssl-unwrap-client-context ctx))))
941      (if server?
942        (ssl-set-accept-state! ssl)
943        (begin
944          (when sni-name
945            (ssl-set-tlsext-hostname! ssl sni-name))
946          (ssl-set-connect-state! ssl)))
947      (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out))))
948
949)
Note: See TracBrowser for help on using the repository browser.