source: project/release/3/openssl/openssl.scm @ 8428

Last change on this file since 8428 was 8428, checked in by elf, 12 years ago

fix for openssl crashes. problem was that the data vector (fd at 0) was itself
being stored at 0, result being that tcp-addresses dies with a 'not a fixnum'.
(as its getting a vector instead). problem discovered and mostly traced
by glogic.

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