source: project/release/5/openssl/tags/2.0.3/openssl.scm @ 37359

Last change on this file since 37359 was 37359, checked in by Vasilij Schneidermann, 3 years ago

Release 2.0.3

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