source: project/release/4/openssl/openssl.scm @ 14315

Last change on this file since 14315 was 14315, checked in by Alex Shinn, 11 years ago

openssl for chicken 4

File size: 15.3 KB
Line 
1;;;; openssl.scm
2;;;; Bindings to the OpenSSL SSL/TLS library
3
4(module openssl
5  (
6   ssl-connect
7   ssl-make-client-context
8   ssl-client-context?
9   ssl-listen
10   ssl-close
11   ssl-listener?
12   ssl-listener?
13   ssl-listener-port
14   ssl-listener-fileno
15   ssl-accept-ready?
16   ssl-accept
17   ssl-load-certificate-chain!
18   ssl-load-private-key!
19   ssl-set-verify!
20   ssl-load-verify-root-certificates!
21   ssl-load-suggested-certificate-authorities!)
22
23(import scheme chicken foreign ports)
24
25(declare
26 (usual-integrations)
27 (no-procedure-checks-for-usual-bindings)
28 (bound-to-procedure
29   ##sys#update-errno
30   ##sys#signal-hook
31   ##sys#string-append
32   ##sys#tcp-port->fileno
33   ##sys#current-thread
34   ##sys#size
35   ##sys#setslot
36   ##sys#check-string
37   ##sys#expand-home-path)
38 (fixnum-arithmetic))
39
40(use srfi-18 tcp)
41
42#>
43#include <errno.h>
44#ifdef _WIN32
45  #ifdef _MSC_VER
46    #include <winsock2.h>
47  #else
48    #include <ws2tcpip.h>
49  #endif
50
51  #include <openssl/rand.h>
52#else
53  #define closesocket     close
54#endif
55
56#ifdef ECOS
57  #include <sys/sockio.h>
58#else
59  #include <unistd.h>
60#endif
61
62#include <openssl/err.h>
63#include <openssl/ssl.h>
64<#
65
66(foreign-code #<<EOF
67ERR_load_crypto_strings();
68SSL_load_error_strings();
69SSL_library_init();
70
71#ifdef _WIN32
72  RAND_screen();
73#endif
74
75EOF
76)
77
78;;; support routines
79
80(define-foreign-variable strerror c-string "strerror(errno)")
81
82(define (net-close-socket fd)
83  (when ((foreign-lambda bool "closesocket" int) fd)
84    (##sys#update-errno)
85    (##sys#signal-hook
86     network-error: 'net-close-socket
87     (##sys#string-append "can not close socket - " strerror)
88     fd)))
89
90(define (net-unwrap-tcp-ports tcp-in tcp-out)
91  (let ((fd (##sys#tcp-port->fileno tcp-in)))
92    (tcp-abandon-port tcp-in)
93    (tcp-abandon-port tcp-out)
94    fd))
95
96(define (ssl-abort loc sym . args)
97  (let ((err ((foreign-lambda unsigned-long "ERR_get_error"))))
98    (abort
99     (make-composite-condition
100      (make-property-condition
101       'exn
102       'message
103       (string-append
104        (if sym
105            (symbol->string sym)
106            "error")
107        ": library="
108        (or
109         ((foreign-lambda c-string "ERR_lib_error_string" unsigned-long)
110          err)
111         "<unknown>")
112        ", function="
113        (or
114         ((foreign-lambda c-string "ERR_func_error_string" unsigned-long)
115          err)
116         "<unknown>")
117        ", reason="
118        (or
119         ((foreign-lambda c-string "ERR_reason_error_string" unsigned-long)
120          err)
121         "<unknown>"))
122       'location
123       loc
124       'arguments args)
125      (make-property-condition
126       'i/o)
127      (make-property-condition
128       'net)
129      (make-property-condition
130       'openssl
131       'status
132       sym)))))
133
134(define ssl-ctx-free (foreign-lambda void "SSL_CTX_free" c-pointer))
135
136(define (ssl-ctx-new protocol server)
137  (let ((ctx
138         ((foreign-lambda*
139           c-pointer ((c-pointer method))
140           "SSL_CTX *ctx;"
141           "if ((ctx = SSL_CTX_new((SSL_METHOD *)method)))\n"
142           "  SSL_CTX_set_mode(ctx, SSL_MODE_ENABLE_PARTIAL_WRITE);\n"
143           "return(ctx);\n")
144          (case protocol
145            ((sslv2-or-v3)
146             (if server
147                 ((foreign-lambda c-pointer "SSLv23_server_method"))
148                 ((foreign-lambda c-pointer "SSLv23_client_method"))))
149            ((sslv2)
150             (if server
151                 ((foreign-lambda c-pointer "SSLv2_server_method"))
152                 ((foreign-lambda c-pointer "SSLv2_client_method"))))
153            ((sslv3)
154             (if server
155                 ((foreign-lambda c-pointer "SSLv3_server_method"))
156                 ((foreign-lambda c-pointer "SSLv3_client_method"))))
157            ((tls)
158             (if server
159                 ((foreign-lambda c-pointer "TLSv1_server_method"))
160                 ((foreign-lambda c-pointer "TLSv1_client_method"))))
161            (else
162             (abort
163              (make-composite-condition
164               (make-property-condition
165                'exn
166                'message "invalid SSL/TLS connection protocol"
167                'location 'ssl-ctx-new
168                'arguments (list protocol))
169               (make-property-condition
170                'type))))))))
171    (unless ctx (ssl-abort 'ssl-ctx-new #f))
172    (set-finalizer! ctx ssl-ctx-free)
173    ctx))
174
175
176(define (ssl-new ctx)
177  (cond
178   (((foreign-lambda c-pointer "SSL_new" c-pointer) ctx)
179    => values)
180   (else
181    (ssl-abort 'ssl-new #f))))
182
183(define ssl-free (foreign-lambda void "SSL_free" c-pointer))
184
185(define (ssl-result-or-abort loc ssl ret allow-i/o? . args)
186  (call-with-current-continuation
187   (lambda (q)
188     (let ((sym
189            (let ((x ((foreign-lambda int "SSL_get_error" c-pointer int)
190                      ssl ret)))
191              (cond
192               ((eq? x (foreign-value "SSL_ERROR_NONE" int))
193                (q ret))
194               ((eq? x (foreign-value "SSL_ERROR_ZERO_RETURN" int))
195                'zero-return)
196               ((eq? x (foreign-value "SSL_ERROR_WANT_READ" int))
197                (if allow-i/o?
198                    (q 'want-read)
199                    'want-read))
200               ((eq? x (foreign-value "SSL_ERROR_WANT_WRITE" int))
201                (if allow-i/o?
202                    (q 'want-write)
203                    'want-write))
204               ((eq? x (foreign-value "SSL_ERROR_WANT_CONNECT" int))
205                'want-connect)
206               ((eq? x (foreign-value "SSL_ERROR_WANT_ACCEPT" int))
207                'want-accept)
208               ((eq? x (foreign-value "SSL_ERROR_WANT_X509_LOOKUP" int))
209                'want-X509-lookup)
210               ((eq? x (foreign-value "SSL_ERROR_SYSCALL" int))
211                'syscall)
212               ((eq? x (foreign-value "SSL_ERROR_SSL" int))
213                'ssl)
214               (else
215                #f)))))
216       (apply ssl-abort loc sym args)))))
217     
218(define (ssl-set-fd! ssl fd)
219  (ssl-result-or-abort
220   'ssl-set-fd! ssl
221   ((foreign-lambda int "SSL_set_fd" c-pointer int) ssl fd) #f
222   fd)
223  (void))
224
225(define (ssl-connect ssl)
226  (ssl-result-or-abort
227   'ssl-connect ssl
228   ((foreign-lambda int "SSL_connect" c-pointer) ssl) #t))
229
230(define (ssl-accept ssl)
231  (ssl-result-or-abort
232   'ssl-accept ssl
233   ((foreign-lambda int "SSL_accept" c-pointer) ssl) #t))
234
235(define (ssl-shutdown ssl)
236  (let ((ret
237         ((foreign-lambda*
238           scheme-object ((c-pointer ssl))
239           "int ret;\n"
240           "switch (ret = SSL_shutdown((SSL *)ssl)) {\n"
241           "case 0: return(C_SCHEME_FALSE);\n"
242           "case 1: return(C_SCHEME_TRUE);\n"
243           "default: return(C_fix(ret));\n"
244           "}\n") ssl)))
245    (if (fixnum? ret)
246        (ssl-result-or-abort 'ssl-shutdown ssl ret #t)
247        ret)))
248
249(define (ssl-get-char ssl)
250  (let ((ret
251         ((foreign-lambda*
252           scheme-object ((c-pointer ssl))
253           "char ch;\n"
254           "int ret;\n"
255           "switch (ret = SSL_read((SSL *)ssl, &ch, 1)) {\n"
256           "case 0: return(C_SCHEME_END_OF_FILE);\n"
257           "case 1: return(C_make_character(ch));\n"
258           "default: return(C_fix(ret));\n"
259           "}\n")
260          ssl)))
261    (if (fixnum? ret)
262        (ssl-result-or-abort 'ssl-get-char ssl ret #t)
263        ret)))
264
265(define (ssl-write ssl buffer offset size)
266  (ssl-result-or-abort
267   'ssl-write ssl
268   ((foreign-lambda*
269     int ((c-pointer ssl) (scheme-pointer buf) (int offset) (int size))
270     "return(SSL_write((SSL *)ssl, (char *)buf + offset, size));\n")
271    ssl buffer offset size)
272   #t))
273
274(define (ssl-make-i/o-ports ctx fd ssl)
275  ;; note that the ctx parameter is never used but it is passed in order
276  ;; to be present in the closure data of the various port functions
277  ;; so it isn't garbage collected before the ports are all gone
278  (let ((in-open? #t) (out-open? #t))
279    (define (shutdown)
280      (unless (or in-open? out-open?)
281        (set! ctx #f) ;; ensure that this reference is lost
282        (dynamic-wind
283            void
284            (lambda ()
285              (let loop ()
286                (case (ssl-shutdown ssl)
287                  ((want-read)
288                   (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
289                   (thread-yield!)
290                   (loop))
291                  ((want-write)
292                   (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
293                   (thread-yield!)
294                   (loop)))))
295            (lambda ()
296              (ssl-free ssl)
297              (net-close-socket fd)))))
298    (let ((data (vector fd))
299          (in
300           (let ((buffer #f))
301             (make-input-port
302              ;; read
303              (lambda ()
304                (unless buffer
305                  (let loop ()
306                    (let ((ret (ssl-get-char ssl)))
307                      (case ret
308                        ((want-read)
309                         (##sys#thread-block-for-i/o!
310                          ##sys#current-thread fd #t)
311                         (thread-yield!)
312                         (loop))
313                        ((want-write)
314                         (##sys#thread-block-for-i/o!
315                          ##sys#current-thread fd #f)
316                         (thread-yield!)
317                         (loop))
318                        (else
319                         (set! buffer ret))))))
320                (if buffer
321                    (let ((ch buffer))
322                      (set! buffer #f)
323                      ch)
324                    #!eof))
325              ;; ready?
326              (lambda ()
327                (or buffer
328                    (let loop ()
329                      (let ((ret (ssl-get-char ssl)))
330                        (case ret
331                          ((want-read want-write)
332                     #f)
333                          (else
334                           (set! buffer ret)))))))
335              ;; close
336              (lambda ()
337                (set! in-open? #f)
338                (shutdown))
339              ;; peek
340              (lambda ()
341                (unless buffer
342                  (let loop ()
343                    (let ((ret (ssl-get-char ssl)))
344                      (case ret
345                        ((want-read)
346                         (##sys#thread-block-for-i/o!
347                          ##sys#current-thread fd #t)
348                         (thread-yield!)
349                         (loop))
350                        ((want-write)
351                         (##sys#thread-block-for-i/o!
352                          ##sys#current-thread fd #f)
353                         (thread-yield!)
354                         (loop))
355                        (else
356                         (set! buffer ret))))))
357                (if buffer
358                    buffer
359                    #!eof)))))
360          (out
361           (make-output-port
362            ;; write
363            (lambda (buffer)
364              (let loop ((offset 0) (size (##sys#size buffer)))
365                (let ((ret (ssl-write ssl buffer offset size)))
366                  (case ret
367                    ((want-read)
368                     (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
369                     (thread-yield!)
370                     (loop offset size))
371                    ((want-write)
372                     (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
373                     (thread-yield!)
374                     (loop offset size))
375                    (else
376                     (if (fx< ret size)
377                         (loop (fx+ offset ret) (fx- size ret))))))))
378            ;; close
379            (lambda ()
380              (set! out-open? #f)
381              (shutdown)))))
382      (##sys#setslot in 3 "(ssl)")
383      (##sys#setslot out 3 "(ssl)")
384      (##sys#setslot in 7 'socket)
385      (##sys#setslot out 7 'socket)
386      (##sys#setslot (##sys#port-data in) 0 fd)
387      (##sys#setslot (##sys#port-data out) 0 fd)
388      (values in out))))
389
390(define (ssl-unwrap-context obj)
391  (cond
392   ((ssl-client-context? obj)
393    (ssl-unwrap-client-context obj))
394   ((ssl-listener? obj)
395    (ssl-unwrap-listener-context obj))
396   (else
397    (abort
398     (make-property-condition
399      'exn
400      'location 'ssl-unwrap-context
401      'message "expected an ssl-client-context or ssl-listener, got"
402      'arguments (list obj))
403     (make-property-condition
404      'type)))))
405
406;;; exported routines
407
408;; create SSL client context
409(define-record-type ssl-client-context
410  (ssl-wrap-client-context context)
411  ssl-client-context?
412  (context ssl-unwrap-client-context))
413
414(define (ssl-make-client-context #!optional (protocol 'sslv2-or-v3))
415  (ssl-wrap-client-context (ssl-ctx-new protocol #f)))
416
417;; connect to SSL server
418(define (ssl-connect hostname #!optional port (ctx 'sslv2-or-v3))
419  (let* ((fd
420          (call-with-values (cut tcp-connect hostname port)
421            net-unwrap-tcp-ports))
422         (ctx
423          (if (ssl-client-context? ctx)
424              (ssl-unwrap-client-context ctx)
425              (ssl-ctx-new ctx #f)))
426         (ssl
427          (ssl-new ctx)))
428    (let ((success? #f))
429      (dynamic-wind
430          void
431          (lambda ()
432            (ssl-set-fd! ssl fd)
433            (let loop ()
434              (case (ssl-connect ssl)
435                ((want-read)
436                 (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
437                 (thread-yield!)
438                 (loop))
439                ((want-write)
440                 (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
441                 (thread-yield!)
442                 (loop))))
443            (set! success? #t))
444          (lambda ()
445            (unless success?
446              (ssl-free ssl)
447              (net-close-socket fd)))))
448    (ssl-make-i/o-ports ctx fd ssl)))
449
450;; create listener/SSL server context
451(define-record-type ssl-listener
452  (ssl-wrap-listener context listener)
453  ssl-listener?
454  (context ssl-unwrap-listener-context)
455  (listener ssl-unwrap-listener))
456
457(define (ssl-listen port #!optional (backlog 4) (hostname #f) (ctx 'sslv2-or-v3))
458  (ssl-wrap-listener
459   (if (ssl-client-context? ctx)
460       (ssl-unwrap-client-context ctx)
461       (ssl-ctx-new ctx #t))
462   (tcp-listen port backlog hostname)))
463
464;; shutdown a SSL server
465(define (ssl-close listener)
466  (tcp-close (ssl-unwrap-listener listener)))
467
468;; return the port number this listener is operating on
469(define (ssl-listener-port listener)
470  (tcp-listener-port (ssl-unwrap-listener listener)))
471
472;; get the underlying socket descriptor number for an SSL listener
473(define (ssl-listener-fileno listener)
474  (tcp-listener-fileno (ssl-unwrap-listener listener)))
475
476;; check whether an incoming connection is pending
477(define (ssl-accept-ready? listener)
478  (tcp-accept-ready? (ssl-unwrap-listener listener)))
479
480;; accept a connection from an SSL listener
481(define (ssl-accept listener)
482  (let* ((fd
483          (call-with-values (cut tcp-accept (ssl-unwrap-listener listener))
484            net-unwrap-tcp-ports))
485         (ssl
486          (ssl-new (ssl-unwrap-listener-context listener))))
487    (let ((success? #f))
488      (dynamic-wind
489          void
490          (lambda ()
491            (ssl-set-fd! ssl fd)
492            (let loop ()
493              (case (ssl-accept ssl)
494                ((want-read)
495                 (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
496                 (thread-yield!)
497                 (loop))
498                ((want-write)
499                 (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
500                 (thread-yield!)
501                 (loop))))
502            (set! success? #t))
503          (lambda ()
504            (unless success?
505              (ssl-free ssl)
506              (net-close-socket fd)))))
507    (ssl-make-i/o-ports (ssl-unwrap-listener-context listener) fd ssl)))
508
509;; load identifying certificate chain into SSL context
510(define (ssl-load-certificate-chain! obj pathname)
511  (##sys#check-string pathname)
512  (unless (eq?
513           ((foreign-lambda
514             int "SSL_CTX_use_certificate_chain_file" c-pointer c-string)
515            (ssl-unwrap-context obj) (##sys#expand-home-path pathname))
516           1)
517    (ssl-abort 'ssl-load-certificate-chain! #f pathname)))
518
519;; load the private key for the identifying certificate chain
520(define (ssl-load-private-key! obj pathname #!optional (rsa? #t) (asn1? #f))
521  (##sys#check-string pathname)
522  (unless (eq?
523           ((foreign-lambda*
524             int ((c-pointer ctx) (c-string path) (bool rsa) (bool asn1))
525             "if (rsa)\n"
526             "  return(SSL_CTX_use_RSAPrivateKey_file("
527             "           (SSL_CTX *)ctx, path, "
528             "           (asn1 ? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));\n"
529             "else\n"
530             "  return(SSL_CTX_use_PrivateKey_file("
531             "           (SSL_CTX *)ctx, path, "
532             "           (asn1 ? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));\n")
533            (ssl-unwrap-context obj) (##sys#expand-home-path pathname)
534            rsa? asn1?)
535           1)
536    (ssl-abort 'ssl-load-private-key! #f pathname rsa? asn1?)))
537
538;; switch verification of peer on or off
539(define (ssl-set-verify! obj v)
540  ((foreign-lambda*
541    void
542    ((c-pointer ctx) (bool verify))
543    "SSL_CTX_set_verify((SSL_CTX *)ctx,"
544    " (verify ? SSL_VERIFY_PEER|SSL_VERIFY_FAIL_IF_NO_PEER_CERT"
545    " : SSL_VERIFY_NONE), NULL);\n")
546   (ssl-unwrap-context obj) v))
547
548;; load trusted root certificates into SSL context
549(define (ssl-load-verify-root-certificates! obj pathname #!optional (dirname #f))
550  (if pathname (##sys#check-string pathname))
551  (if dirname (##sys#check-string dirname))
552  (unless (eq?
553           ((foreign-lambda
554             int "SSL_CTX_load_verify_locations" c-pointer c-string c-string)
555            (ssl-unwrap-context obj)
556            (if pathname (##sys#expand-home-path pathname) #f)
557            (if dirname (##sys#expand-home-path dirname) #f))
558           1)
559    (ssl-abort 'ssl-load-verify-root-certificates! #f pathname dirname)))
560
561;; load suggested root certificates into SSL context
562(define (ssl-load-suggested-certificate-authorities! obj pathname)
563  (##sys#check-string pathname)
564  (cond
565   (((foreign-lambda c-pointer "SSL_load_client_CA_file" c-string)
566     (##sys#expand-home-path pathname))
567    => (cut
568        (foreign-lambda
569         void "SSL_CTX_set_client_CA_list" c-pointer c-pointer)
570        (ssl-unwrap-context obj) <>))
571   (else
572    ssl-abort 'ssl-load-suggested-certificate-authorities! #f pathname)))
573
574)
Note: See TracBrowser for help on using the repository browser.