source: project/release/5/openssl/tags/2.0.1/openssl.scm @ 36598

Last change on this file since 36598 was 36598, checked in by wasamasa, 2 years ago

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