suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

untabify, #lang

Browse Source
This commit is contained in:
Ryan Culpepper 2012-11-24 18:12:57 -05:00
parent 438f906fb9
commit 3d37eb4ae4
1 changed files with 1308 additions and 1308 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

474
collects/openssl/mzssl.rkt
View File

@ -14,8 +14,8 @@
;; read/write (the opposite direction) didn't finish, and so that ;; read/write (the opposite direction) didn't finish, and so that
;; opposite must be completed, first. ;; opposite must be completed, first.
(module mzssl racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
ffi/unsafe/define ffi/unsafe/define
ffi/unsafe/atomic ffi/unsafe/atomic
ffi/unsafe/alloc ffi/unsafe/alloc
@ -26,10 +26,10 @@
unstable/lazy-require unstable/lazy-require
"libcrypto.rkt" "libcrypto.rkt"
"libssl.rkt") "libssl.rkt")
(lazy-require (lazy-require
["private/win32.rkt" (load-win32-root-certificates)]) ["private/win32.rkt" (load-win32-root-certificates)])
(provide ssl-available? (provide ssl-available?
ssl-load-fail-reason ssl-load-fail-reason
ssl-make-client-context ssl-make-client-context
@ -75,125 +75,125 @@
ssl-port?) ssl-port?)
(define ssl-load-fail-reason (define ssl-load-fail-reason
(or libssl-load-fail-reason (or libssl-load-fail-reason
libcrypto-load-fail-reason)) libcrypto-load-fail-reason))
(define 3m? (eq? '3m (system-type 'gc))) (define 3m? (eq? '3m (system-type 'gc)))
(define libmz (ffi-lib #f)) (define libmz (ffi-lib #f))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SSL bindings and constants ;; SSL bindings and constants
(define-ffi-definer define-crypto libcrypto (define-ffi-definer define-crypto libcrypto
#:default-make-fail make-not-available) #:default-make-fail make-not-available)
(define-ffi-definer define-ssl libssl (define-ffi-definer define-ssl libssl
#:default-make-fail make-not-available) #:default-make-fail make-not-available)
(define-ffi-definer define-mzscheme libmz) (define-ffi-definer define-mzscheme libmz)
(define-cpointer-type _BIO_METHOD*) (define-cpointer-type _BIO_METHOD*)
(define-cpointer-type _BIO*) (define-cpointer-type _BIO*)
(define-cpointer-type _SSL_METHOD*) (define-cpointer-type _SSL_METHOD*)
(define-cpointer-type _SSL_CTX*) (define-cpointer-type _SSL_CTX*)
(define-cpointer-type _SSL*) (define-cpointer-type _SSL*)
(define-cpointer-type _X509_NAME*) (define-cpointer-type _X509_NAME*)
(define-cpointer-type _X509_NAME_ENTRY*) (define-cpointer-type _X509_NAME_ENTRY*)
(define-cpointer-type _X509*) (define-cpointer-type _X509*)
(define-cpointer-type _ASN1_STRING*) (define-cpointer-type _ASN1_STRING*)
(define-cpointer-type _STACK*) (define-cpointer-type _STACK*)
(define-cstruct _GENERAL_NAME ([type _int] [d _ASN1_STRING*])) (define-cstruct _GENERAL_NAME ([type _int] [d _ASN1_STRING*]))
(define-ssl SSLv2_client_method (_fun -> _SSL_METHOD*)) (define-ssl SSLv2_client_method (_fun -> _SSL_METHOD*))
(define-ssl SSLv2_server_method (_fun -> _SSL_METHOD*)) (define-ssl SSLv2_server_method (_fun -> _SSL_METHOD*))
(define-ssl SSLv3_client_method (_fun -> _SSL_METHOD*)) (define-ssl SSLv3_client_method (_fun -> _SSL_METHOD*))
(define-ssl SSLv3_server_method (_fun -> _SSL_METHOD*)) (define-ssl SSLv3_server_method (_fun -> _SSL_METHOD*))
(define-ssl SSLv23_client_method (_fun -> _SSL_METHOD*)) (define-ssl SSLv23_client_method (_fun -> _SSL_METHOD*))
(define-ssl SSLv23_server_method (_fun -> _SSL_METHOD*)) (define-ssl SSLv23_server_method (_fun -> _SSL_METHOD*))
(define-ssl TLSv1_client_method (_fun -> _SSL_METHOD*)) (define-ssl TLSv1_client_method (_fun -> _SSL_METHOD*))
(define-ssl TLSv1_server_method (_fun -> _SSL_METHOD*)) (define-ssl TLSv1_server_method (_fun -> _SSL_METHOD*))
(define-crypto BIO_s_mem (_fun -> _BIO_METHOD*)) (define-crypto BIO_s_mem (_fun -> _BIO_METHOD*))
(define-crypto BIO_new (_fun _BIO_METHOD* -> _BIO*/null)) (define-crypto BIO_new (_fun _BIO_METHOD* -> _BIO*/null))
(define-crypto BIO_free (_fun _BIO* -> _void)) (define-crypto BIO_free (_fun _BIO* -> _void))
(define-crypto BIO_read (_fun _BIO* _bytes _int -> _int)) (define-crypto BIO_read (_fun _BIO* _bytes _int -> _int))
(define-crypto BIO_write (_fun _BIO* _bytes _int -> _int)) (define-crypto BIO_write (_fun _BIO* _bytes _int -> _int))
(define-crypto BIO_ctrl (_fun _BIO* _int _long _long -> _long)) (define-crypto BIO_ctrl (_fun _BIO* _int _long _long -> _long))
(define (BIO_set_mem_eof_return b v) (define (BIO_set_mem_eof_return b v)
(BIO_ctrl b BIO_C_SET_BUF_MEM_EOF_RETURN v 0)) (BIO_ctrl b BIO_C_SET_BUF_MEM_EOF_RETURN v 0))
(define-ssl SSL_CTX_free (_fun _SSL_CTX* -> _void) (define-ssl SSL_CTX_free (_fun _SSL_CTX* -> _void)
#:wrap (deallocator)) #:wrap (deallocator))
(define-ssl SSL_CTX_new (_fun _SSL_METHOD* -> _SSL_CTX*) (define-ssl SSL_CTX_new (_fun _SSL_METHOD* -> _SSL_CTX*)
#:wrap (allocator SSL_CTX_free)) #:wrap (allocator SSL_CTX_free))
(define-ssl SSL_CTX_ctrl (_fun _SSL_CTX* _int _long _pointer -> _long)) (define-ssl SSL_CTX_ctrl (_fun _SSL_CTX* _int _long _pointer -> _long))
(define (SSL_CTX_set_mode ctx m) (define (SSL_CTX_set_mode ctx m)
(SSL_CTX_ctrl ctx SSL_CTRL_MODE m #f)) (SSL_CTX_ctrl ctx SSL_CTRL_MODE m #f))
(define-ssl SSL_CTX_set_verify (_fun _SSL_CTX* _int _pointer -> _void)) (define-ssl SSL_CTX_set_verify (_fun _SSL_CTX* _int _pointer -> _void))
(define-ssl SSL_CTX_use_certificate_chain_file (_fun _SSL_CTX* _bytes -> _int)) (define-ssl SSL_CTX_use_certificate_chain_file (_fun _SSL_CTX* _bytes -> _int))
(define-ssl SSL_CTX_load_verify_locations (_fun _SSL_CTX* _bytes _bytes -> _int)) (define-ssl SSL_CTX_load_verify_locations (_fun _SSL_CTX* _bytes _bytes -> _int))
(define-ssl SSL_CTX_set_client_CA_list (_fun _SSL_CTX* _X509_NAME* -> _int)) (define-ssl SSL_CTX_set_client_CA_list (_fun _SSL_CTX* _X509_NAME* -> _int))
(define-ssl SSL_CTX_set_session_id_context (_fun _SSL_CTX* _bytes _int -> _int)) (define-ssl SSL_CTX_set_session_id_context (_fun _SSL_CTX* _bytes _int -> _int))
(define-ssl SSL_CTX_use_RSAPrivateKey_file (_fun _SSL_CTX* _bytes _int -> _int)) (define-ssl SSL_CTX_use_RSAPrivateKey_file (_fun _SSL_CTX* _bytes _int -> _int))
(define-ssl SSL_CTX_use_PrivateKey_file (_fun _SSL_CTX* _bytes _int -> _int)) (define-ssl SSL_CTX_use_PrivateKey_file (_fun _SSL_CTX* _bytes _int -> _int))
(define-ssl SSL_load_client_CA_file (_fun _bytes -> _X509_NAME*/null)) (define-ssl SSL_load_client_CA_file (_fun _bytes -> _X509_NAME*/null))
(define-ssl SSL_CTX_set_cipher_list (_fun _SSL_CTX* _string -> _int)) (define-ssl SSL_CTX_set_cipher_list (_fun _SSL_CTX* _string -> _int))
(define-ssl SSL_free (_fun _SSL* -> _void) (define-ssl SSL_free (_fun _SSL* -> _void)
#:wrap (deallocator)) #:wrap (deallocator))
(define-ssl SSL_new (_fun _SSL_CTX* -> _SSL*) (define-ssl SSL_new (_fun _SSL_CTX* -> _SSL*)
#:wrap (allocator SSL_free)) #:wrap (allocator SSL_free))
(define-ssl SSL_set_bio (_fun _SSL* _BIO* _BIO* -> _void)) (define-ssl SSL_set_bio (_fun _SSL* _BIO* _BIO* -> _void))
(define-ssl SSL_connect (_fun _SSL* -> _int)) (define-ssl SSL_connect (_fun _SSL* -> _int))
(define-ssl SSL_accept (_fun _SSL* -> _int)) (define-ssl SSL_accept (_fun _SSL* -> _int))
(define-ssl SSL_read (_fun _SSL* _bytes _int -> _int)) (define-ssl SSL_read (_fun _SSL* _bytes _int -> _int))
(define-ssl SSL_write (_fun _SSL* _bytes _int -> _int)) (define-ssl SSL_write (_fun _SSL* _bytes _int -> _int))
(define-ssl SSL_shutdown (_fun _SSL* -> _int)) (define-ssl SSL_shutdown (_fun _SSL* -> _int))
(define-ssl SSL_get_verify_result (_fun _SSL* -> _long)) (define-ssl SSL_get_verify_result (_fun _SSL* -> _long))
(define-ssl SSL_set_verify (_fun _SSL* _int _pointer -> _void)) (define-ssl SSL_set_verify (_fun _SSL* _int _pointer -> _void))
(define-ssl SSL_set_session_id_context (_fun _SSL* _bytes _int -> _int)) (define-ssl SSL_set_session_id_context (_fun _SSL* _bytes _int -> _int))
(define-ssl SSL_renegotiate (_fun _SSL* -> _int)) (define-ssl SSL_renegotiate (_fun _SSL* -> _int))
(define-ssl SSL_renegotiate_pending (_fun _SSL* -> _int)) (define-ssl SSL_renegotiate_pending (_fun _SSL* -> _int))
(define-ssl SSL_do_handshake (_fun _SSL* -> _int)) (define-ssl SSL_do_handshake (_fun _SSL* -> _int))
(define-crypto X509_free (_fun _X509* -> _void) (define-crypto X509_free (_fun _X509* -> _void)
#:wrap (deallocator)) #:wrap (deallocator))
(define-ssl SSL_get_peer_certificate (_fun _SSL* -> _X509*/null) (define-ssl SSL_get_peer_certificate (_fun _SSL* -> _X509*/null)
#:wrap (allocator X509_free)) #:wrap (allocator X509_free))
(define-crypto X509_get_subject_name (_fun _X509* -> _X509_NAME*)) (define-crypto X509_get_subject_name (_fun _X509* -> _X509_NAME*))
(define-crypto X509_get_issuer_name (_fun _X509* -> _X509_NAME*)) (define-crypto X509_get_issuer_name (_fun _X509* -> _X509_NAME*))
(define-crypto X509_NAME_oneline (_fun _X509_NAME* _bytes _int -> _bytes)) (define-crypto X509_NAME_oneline (_fun _X509_NAME* _bytes _int -> _bytes))
(define-ssl SSL_get_error (_fun _SSL* _int -> _int)) (define-ssl SSL_get_error (_fun _SSL* _int -> _int))
(define-crypto ERR_get_error (_fun -> _long)) (define-crypto ERR_get_error (_fun -> _long))
(define-crypto ERR_error_string_n (_fun _long _bytes _long -> _void)) (define-crypto ERR_error_string_n (_fun _long _bytes _long -> _void))
(define-ssl SSL_library_init (_fun -> _void)) (define-ssl SSL_library_init (_fun -> _void))
(define-ssl SSL_load_error_strings (_fun -> _void)) (define-ssl SSL_load_error_strings (_fun -> _void))
(define-crypto GENERAL_NAME_free _fpointer) (define-crypto GENERAL_NAME_free _fpointer)
(define-crypto ASN1_STRING_length (_fun _ASN1_STRING* -> _int)) (define-crypto ASN1_STRING_length (_fun _ASN1_STRING* -> _int))
(define-crypto ASN1_STRING_data (_fun _ASN1_STRING* -> _pointer)) (define-crypto ASN1_STRING_data (_fun _ASN1_STRING* -> _pointer))
(define-crypto X509_NAME_get_index_by_NID (_fun _X509_NAME* _int _int -> _int)) (define-crypto X509_NAME_get_index_by_NID (_fun _X509_NAME* _int _int -> _int))
(define-crypto X509_NAME_get_entry (_fun _X509_NAME* _int -> _X509_NAME_ENTRY*/null)) (define-crypto X509_NAME_get_entry (_fun _X509_NAME* _int -> _X509_NAME_ENTRY*/null))
(define-crypto X509_NAME_ENTRY_get_data (_fun _X509_NAME_ENTRY* -> _ASN1_STRING*)) (define-crypto X509_NAME_ENTRY_get_data (_fun _X509_NAME_ENTRY* -> _ASN1_STRING*))
(define-crypto X509_get_ext_d2i (_fun _X509* _int _pointer _pointer -> _STACK*/null)) (define-crypto X509_get_ext_d2i (_fun _X509* _int _pointer _pointer -> _STACK*/null))
(define-crypto sk_num (_fun _STACK* -> _int)) (define-crypto sk_num (_fun _STACK* -> _int))
(define-crypto sk_GENERAL_NAME_value (_fun _STACK* _int -> _GENERAL_NAME-pointer) (define-crypto sk_GENERAL_NAME_value (_fun _STACK* _int -> _GENERAL_NAME-pointer)
#:c-id sk_value) #:c-id sk_value)
(define-crypto sk_pop_free (_fun _STACK* _fpointer -> _void)) (define-crypto sk_pop_free (_fun _STACK* _fpointer -> _void))
;; (define-crypto X509_get_default_cert_area (_fun -> _string)) ;; (define-crypto X509_get_default_cert_area (_fun -> _string))
(define-crypto X509_get_default_cert_dir (_fun -> _string)) (define-crypto X509_get_default_cert_dir (_fun -> _string))
(define-crypto X509_get_default_cert_file (_fun -> _string)) (define-crypto X509_get_default_cert_file (_fun -> _string))
(define-crypto X509_get_default_cert_dir_env (_fun -> _string)) (define-crypto X509_get_default_cert_dir_env (_fun -> _string))
(define-crypto X509_get_default_cert_file_env (_fun -> _string)) (define-crypto X509_get_default_cert_file_env (_fun -> _string))
(define (x509-root-sources) (define (x509-root-sources)
(define (dir-sep) (define (dir-sep)
(case (system-type) (case (system-type)
[(windows) ";"] [(windows) ";"]
@ -211,7 +211,7 @@
(append (get-paths X509_get_default_cert_file_env X509_get_default_cert_file #f #f) (append (get-paths X509_get_default_cert_file_env X509_get_default_cert_file #f #f)
(get-paths X509_get_default_cert_dir_env X509_get_default_cert_dir #t #t))) (get-paths X509_get_default_cert_dir_env X509_get_default_cert_dir #t #t)))
(define ssl-default-verify-sources (define ssl-default-verify-sources
(make-parameter (make-parameter
(case (system-type) (case (system-type)
[(windows) [(windows)
@ -224,48 +224,48 @@
[else [else
(x509-root-sources)]))) (x509-root-sources)])))
(define X509_V_OK 0) (define X509_V_OK 0)
(define SSL_ERROR_SSL 1) (define SSL_ERROR_SSL 1)
(define SSL_ERROR_WANT_READ 2) (define SSL_ERROR_WANT_READ 2)
(define SSL_ERROR_WANT_WRITE 3) (define SSL_ERROR_WANT_WRITE 3)
(define SSL_ERROR_SYSCALL 5) (define SSL_ERROR_SYSCALL 5)
(define SSL_ERROR_ZERO_RETURN 6) (define SSL_ERROR_ZERO_RETURN 6)
(define BIO_C_SET_BUF_MEM_EOF_RETURN 130) (define BIO_C_SET_BUF_MEM_EOF_RETURN 130)
(define SSL_FILETYPE_PEM 1) (define SSL_FILETYPE_PEM 1)
(define SSL_FILETYPE_ASN1 2) (define SSL_FILETYPE_ASN1 2)
(define SSL_VERIFY_NONE #x00) (define SSL_VERIFY_NONE #x00)
(define SSL_VERIFY_PEER #x01) (define SSL_VERIFY_PEER #x01)
(define SSL_VERIFY_FAIL_IF_NO_PEER_CERT #x02) (define SSL_VERIFY_FAIL_IF_NO_PEER_CERT #x02)
(define SSL_MODE_ENABLE_PARTIAL_WRITE #x01) (define SSL_MODE_ENABLE_PARTIAL_WRITE #x01)
(define SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER #x02) (define SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER #x02)
(define SSL_CTRL_MODE 33) (define SSL_CTRL_MODE 33)
(define NID_subject_alt_name 85) (define NID_subject_alt_name 85)
(define NID_commonName 13) (define NID_commonName 13)
(define GEN_DNS 2) (define GEN_DNS 2)
(define-mzscheme scheme_make_custodian (_fun _pointer -> _scheme)) (define-mzscheme scheme_make_custodian (_fun _pointer -> _scheme))
;; Make this bigger than 4096 to accommodate at least ;; Make this bigger than 4096 to accommodate at least
;; 4096 of unencrypted data ;; 4096 of unencrypted data
(define BUFFER-SIZE 8000) (define BUFFER-SIZE 8000)
;; The man pages for SSL_read and SSL_write say that they must be ;; The man pages for SSL_read and SSL_write say that they must be
;; retried with the same arguments when they return SSL_ERROR_WANT_READ ;; retried with the same arguments when they return SSL_ERROR_WANT_READ
;; or SSL_ERROR_WANT_WRITE. This may not actually be true, especially ;; or SSL_ERROR_WANT_WRITE. This may not actually be true, especially
;; when SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER is used, and "retry" may or ;; when SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER is used, and "retry" may or
;; may not mean "retry without doing other things first". Set `enforce-retry?' ;; may not mean "retry without doing other things first". Set `enforce-retry?'
;; to #t to obey the manpage and retry without doing other things, which ;; to #t to obey the manpage and retry without doing other things, which
;; has an implicitation for clients as noted at the top of this file. ;; has an implicitation for clients as noted at the top of this file.
(define enforce-retry? #f) (define enforce-retry? #f)
;; Needed for `renegotiate': ;; Needed for `renegotiate':
(define-cstruct _ssl_struct ([version _int] (define-cstruct _ssl_struct ([version _int]
[type _int] [type _int]
[method _pointer] [method _pointer]
[rbio _pointer] [rbio _pointer]
@ -282,12 +282,12 @@
;; ... ;; ...
)) ))
(define SSL_ST_ACCEPT #x2000) (define SSL_ST_ACCEPT #x2000)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Error handling ;; Error handling
(define-syntax with-failure (define-syntax with-failure
(syntax-rules () (syntax-rules ()
[(_ thunk body ...) [(_ thunk body ...)
(with-handlers ([exn? (lambda (exn) (with-handlers ([exn? (lambda (exn)
@ -295,40 +295,40 @@
(raise exn))]) (raise exn))])
body ...)])) body ...)]))
(define (get-error-message id) (define (get-error-message id)
(let* ([buffer (make-bytes 512)]) (let* ([buffer (make-bytes 512)])
(ERR_error_string_n id buffer (bytes-length buffer)) (ERR_error_string_n id buffer (bytes-length buffer))
(regexp-match #rx#"^[^\0]*" buffer))) (regexp-match #rx#"^[^\0]*" buffer)))
(define (check-valid v who what) (define (check-valid v who what)
(when (ptr-equal? v #f) (when (ptr-equal? v #f)
(let ([id (ERR_get_error)]) (let ([id (ERR_get_error)])
(error who "~a failed ~a" what (get-error-message id))))) (error who "~a failed ~a" what (get-error-message id)))))
(define (error/network who fmt . args) (define (error/network who fmt . args)
(raise (make-exn:fail:network (raise (make-exn:fail:network
(format "~a: ~a" who (apply format fmt args)) (format "~a: ~a" who (apply format fmt args))
(current-continuation-marks)))) (current-continuation-marks))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Atomic blocks ;; Atomic blocks
(define-syntax-rule (atomically body ...) (define-syntax-rule (atomically body ...)
(call-as-atomic (lambda () body ...))) (call-as-atomic (lambda () body ...)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Structs ;; Structs
(define-struct ssl-context (ctx [verify-hostname? #:mutable] [sealed? #:mutable])) (define-struct ssl-context (ctx [verify-hostname? #:mutable] [sealed? #:mutable]))
(define-struct (ssl-client-context ssl-context) ()) (define-struct (ssl-client-context ssl-context) ())
(define-struct (ssl-server-context ssl-context) ()) (define-struct (ssl-server-context ssl-context) ())
(define-struct ssl-listener (l mzctx) (define-struct ssl-listener (l mzctx)
#:property prop:evt (lambda (lst) (wrap-evt (ssl-listener-l lst) #:property prop:evt (lambda (lst) (wrap-evt (ssl-listener-l lst)
(lambda (x) lst)))) (lambda (x) lst))))
;; internal: ;; internal:
(define-struct mzssl (ssl i o r-bio w-bio pipe-r pipe-w (define-struct mzssl (ssl i o r-bio w-bio pipe-r pipe-w
buffer lock buffer lock
w-closed? r-closed? w-closed? r-closed?
flushing? must-write must-read flushing? must-write must-read
@ -337,7 +337,7 @@
error) error)
#:mutable) #:mutable)
(define (make-immobile-bytes n) (define (make-immobile-bytes n)
(if 3m? (if 3m?
;; Allocate the byte string via malloc: ;; Allocate the byte string via malloc:
(let ([p (malloc 'atomic-interior n)]) (let ([p (malloc 'atomic-interior n)])
@ -345,10 +345,10 @@
;; Normal byte string is immobile: ;; Normal byte string is immobile:
(make-bytes n))) (make-bytes n)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Errors ;; Errors
(define (do-save-errors thunk ssl) (define (do-save-errors thunk ssl)
;; Atomically run a function and get error results ;; Atomically run a function and get error results
;; so that this library is thread-safe (at the level of Racket threads) ;; so that this library is thread-safe (at the level of Racket threads)
(atomically (atomically
@ -369,15 +369,15 @@
[else unknown])) [else unknown]))
(values v e estr))) (values v e estr)))
(define-syntax-rule (save-errors e ssl) (define-syntax-rule (save-errors e ssl)
(do-save-errors (lambda () e) ssl)) (do-save-errors (lambda () e) ssl))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Contexts, certificates, etc. ;; Contexts, certificates, etc.
(define default-encrypt 'sslv2-or-v3) (define default-encrypt 'sslv2-or-v3)
(define (encrypt->method who also-expect e client?) (define (encrypt->method who also-expect e client?)
((case e ((case e
[(sslv2-or-v3) (if client? [(sslv2-or-v3) (if client?
SSLv23_client_method SSLv23_client_method
@ -396,7 +396,7 @@
(format "(or/c ~a'sslv2-or-v3 'sslv2 'sslv3 'tls)" also-expect) (format "(or/c ~a'sslv2-or-v3 'sslv2 'sslv3 'tls)" also-expect)
e)]))) e)])))
(define (make-context who protocol-symbol also-expected client?) (define (make-context who protocol-symbol also-expected client?)
(let ([meth (encrypt->method who also-expected protocol-symbol client?)]) (let ([meth (encrypt->method who also-expected protocol-symbol client?)])
(atomically ;; connect SSL_CTX_new to subsequent check-valid (ERR_get_error) (atomically ;; connect SSL_CTX_new to subsequent check-valid (ERR_get_error)
(let ([ctx (SSL_CTX_new meth)]) (let ([ctx (SSL_CTX_new meth)])
@ -405,13 +405,13 @@
SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER)) SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER))
((if client? make-ssl-client-context make-ssl-server-context) ctx #f #f))))) ((if client? make-ssl-client-context make-ssl-server-context) ctx #f #f)))))
(define (ssl-make-client-context [protocol-symbol default-encrypt]) (define (ssl-make-client-context [protocol-symbol default-encrypt])
(make-context 'ssl-make-client-context protocol-symbol "" #t)) (make-context 'ssl-make-client-context protocol-symbol "" #t))
(define (ssl-make-server-context [protocol-symbol default-encrypt]) (define (ssl-make-server-context [protocol-symbol default-encrypt])
(make-context 'ssl-make-server-context protocol-symbol "" #f)) (make-context 'ssl-make-server-context protocol-symbol "" #f))
(define (get-context who context-or-encrypt-method client? (define (get-context who context-or-encrypt-method client?
#:need-unsealed? [need-unsealed? #f]) #:need-unsealed? [need-unsealed? #f])
(if (ssl-context? context-or-encrypt-method) (if (ssl-context? context-or-encrypt-method)
(extract-ctx who need-unsealed? context-or-encrypt-method) (extract-ctx who need-unsealed? context-or-encrypt-method)
@ -419,7 +419,7 @@
(SSL_CTX_set_mode ctx SSL_MODE_ENABLE_PARTIAL_WRITE) (SSL_CTX_set_mode ctx SSL_MODE_ENABLE_PARTIAL_WRITE)
ctx))) ctx)))
(define (get-context/listener who ssl-context-or-listener [fail? #t] (define (get-context/listener who ssl-context-or-listener [fail? #t]
#:need-unsealed? [need-unsealed? #f]) #:need-unsealed? [need-unsealed? #f])
(cond (cond
[(ssl-context? ssl-context-or-listener) [(ssl-context? ssl-context-or-listener)
@ -433,19 +433,19 @@
ssl-context-or-listener) ssl-context-or-listener)
#f)])) #f)]))
(define (extract-ctx who need-unsealed? mzctx) (define (extract-ctx who need-unsealed? mzctx)
(when (and need-unsealed? (ssl-context-sealed? mzctx)) (when (and need-unsealed? (ssl-context-sealed? mzctx))
(error who "context is sealed; no further changes are allowed")) (error who "context is sealed; no further changes are allowed"))
(ssl-context-ctx mzctx)) (ssl-context-ctx mzctx))
(define (ssl-seal-context! mzctx) (define (ssl-seal-context! mzctx)
(unless (ssl-context? mzctx) (unless (ssl-context? mzctx)
(raise-argument-error 'ssl-seal-context! (raise-argument-error 'ssl-seal-context!
"(or/c ssl-client-context? ssl-server-context?)" "(or/c ssl-client-context? ssl-server-context?)"
mzctx)) mzctx))
(set-ssl-context-sealed?! mzctx #t)) (set-ssl-context-sealed?! mzctx #t))
(define (ssl-load-... who load-it ssl-context-or-listener pathname (define (ssl-load-... who load-it ssl-context-or-listener pathname
#:try? [try? #f]) #:try? [try? #f])
(let ([ctx (get-context/listener who ssl-context-or-listener (let ([ctx (get-context/listener who ssl-context-or-listener
#:need-unsealed? #t)]) #:need-unsealed? #t)])
@ -465,12 +465,12 @@
pathname pathname
(get-error-message (ERR_get_error)))))))))) (get-error-message (ERR_get_error))))))))))
(define (ssl-load-certificate-chain! ssl-context-or-listener pathname) (define (ssl-load-certificate-chain! ssl-context-or-listener pathname)
(ssl-load-... 'ssl-load-certificate-chain! (ssl-load-... 'ssl-load-certificate-chain!
SSL_CTX_use_certificate_chain_file SSL_CTX_use_certificate_chain_file
ssl-context-or-listener pathname)) ssl-context-or-listener pathname))
(define (ssl-load-suggested-certificate-authorities! ssl-listener pathname) (define (ssl-load-suggested-certificate-authorities! ssl-listener pathname)
(ssl-load-... 'ssl-load-suggested-certificate-authorities! (ssl-load-... 'ssl-load-suggested-certificate-authorities!
(lambda (ctx path) (lambda (ctx path)
(let ([stk (SSL_load_client_CA_file path)]) (let ([stk (SSL_load_client_CA_file path)])
@ -481,7 +481,7 @@
1)))) 1))))
ssl-listener pathname)) ssl-listener pathname))
(define (ssl-load-private-key! ssl-context-or-listener pathname (define (ssl-load-private-key! ssl-context-or-listener pathname
[rsa? #t] [asn1? #f]) [rsa? #t] [asn1? #f])
(ssl-load-... (ssl-load-...
'ssl-load-private-key! 'ssl-load-private-key!
@ -491,12 +491,12 @@
(if asn1? SSL_FILETYPE_ASN1 SSL_FILETYPE_PEM))) (if asn1? SSL_FILETYPE_ASN1 SSL_FILETYPE_PEM)))
ssl-context-or-listener pathname)) ssl-context-or-listener pathname))
(define (ssl-load-verify-root-certificates! scl src) (define (ssl-load-verify-root-certificates! scl src)
(ssl-load-... 'ssl-load-verify-root-certificates! (ssl-load-... 'ssl-load-verify-root-certificates!
(lambda (a b) (SSL_CTX_load_verify_locations a b #f)) (lambda (a b) (SSL_CTX_load_verify_locations a b #f))
scl src)) scl src))
(define (ssl-load-verify-source! context src #:try? [try? #f]) (define (ssl-load-verify-source! context src #:try? [try? #f])
(define (bad-source) (define (bad-source)
(error 'ssl-load-verify-root-certificates! (error 'ssl-load-verify-root-certificates!
"bad source: ~e" src)) "bad source: ~e" src))
@ -525,11 +525,11 @@
[else (bad-source)]))] [else (bad-source)]))]
[else (bad-source)])) [else (bad-source)]))
(define (ssl-load-default-verify-sources! ctx) (define (ssl-load-default-verify-sources! ctx)
(for ([src (in-list (ssl-default-verify-sources))]) (for ([src (in-list (ssl-default-verify-sources))])
(ssl-load-verify-source! ctx src #:try? #t))) (ssl-load-verify-source! ctx src #:try? #t)))
(define (ssl-set-ciphers! context cipher-spec) (define (ssl-set-ciphers! context cipher-spec)
(unless (ssl-context? context) (unless (ssl-context? context)
(raise-argument-error 'ssl-set-ciphers! (raise-argument-error 'ssl-set-ciphers!
"(or/c ssl-client-context? ssl-server-context?)" "(or/c ssl-client-context? ssl-server-context?)"
@ -542,7 +542,7 @@
(error 'ssl-set-ciphers! "setting cipher list failed")) (error 'ssl-set-ciphers! "setting cipher list failed"))
(void))) (void)))
(define (ssl-set-verify-hostname! ssl-context on?) (define (ssl-set-verify-hostname! ssl-context on?)
(unless (ssl-context? ssl-context) (unless (ssl-context? ssl-context)
(raise-argument-error 'ssl-set-verify-hostname! (raise-argument-error 'ssl-set-verify-hostname!
"(or/c ssl-client-context? ssl-server-context?)" "(or/c ssl-client-context? ssl-server-context?)"
@ -550,18 +550,18 @@
(void (extract-ctx 'ssl-set-verify-hostname! #t ssl-context)) (void (extract-ctx 'ssl-set-verify-hostname! #t ssl-context))
(set-ssl-context-verify-hostname?! ssl-context (and on? #t))) (set-ssl-context-verify-hostname?! ssl-context (and on? #t)))
(define (ssl-try-verify! ssl-context-or-listener-or-port on?) (define (ssl-try-verify! ssl-context-or-listener-or-port on?)
(do-ssl-set-verify! ssl-context-or-listener-or-port on? (do-ssl-set-verify! ssl-context-or-listener-or-port on?
'ssl-try-verify! 'ssl-try-verify!
SSL_VERIFY_PEER)) SSL_VERIFY_PEER))
(define (ssl-set-verify! ssl-context-or-listener-or-port on?) (define (ssl-set-verify! ssl-context-or-listener-or-port on?)
(do-ssl-set-verify! ssl-context-or-listener-or-port on? (do-ssl-set-verify! ssl-context-or-listener-or-port on?
'ssl-set-verify! 'ssl-set-verify!
(bitwise-ior SSL_VERIFY_PEER (bitwise-ior SSL_VERIFY_PEER
SSL_VERIFY_FAIL_IF_NO_PEER_CERT))) SSL_VERIFY_FAIL_IF_NO_PEER_CERT)))
(define (do-ssl-set-verify! ssl-context-or-listener-or-port on? who mode) (define (do-ssl-set-verify! ssl-context-or-listener-or-port on? who mode)
(cond (cond
[(get-context/listener who [(get-context/listener who
ssl-context-or-listener-or-port ssl-context-or-listener-or-port
@ -591,7 +591,7 @@
(SSL_set_session_id_context (mzssl-ssl mzssl) bytes (bytes-length bytes))) (SSL_set_session_id_context (mzssl-ssl mzssl) bytes (bytes-length bytes)))
(when on? (renegotiate who mzssl)))])) (when on? (renegotiate who mzssl)))]))
(define (renegotiate who mzssl) (define (renegotiate who mzssl)
(define (check-err thunk) (define (check-err thunk)
(let loop () (let loop ()
(define-values (v err estr) (save-errors (thunk) (mzssl-ssl mzssl))) (define-values (v err estr) (save-errors (thunk) (mzssl-ssl mzssl)))
@ -625,9 +625,9 @@
SSL_ST_ACCEPT) SSL_ST_ACCEPT)
(check-err (lambda () (SSL_do_handshake (mzssl-ssl mzssl)))))) (check-err (lambda () (SSL_do_handshake (mzssl-ssl mzssl))))))
;; ---- ;; ----
(define (ssl-make-secure-client-context sym) (define (ssl-make-secure-client-context sym)
(let ([ctx (ssl-make-client-context sym)]) (let ([ctx (ssl-make-client-context sym)])
;; Load root certificates ;; Load root certificates
(ssl-load-default-verify-sources! ctx) (ssl-load-default-verify-sources! ctx)
@ -640,10 +640,10 @@
(ssl-seal-context! ctx) (ssl-seal-context! ctx)
ctx)) ctx))
;; context-cache: (list (weak-box ssl-client-context) (listof path-string) nat) or #f ;; context-cache: (list (weak-box ssl-client-context) (listof path-string) nat) or #f
(define context-cache #f) (define context-cache #f)
(define (ssl-secure-client-context) (define (ssl-secure-client-context)
(let ([locs (ssl-default-verify-sources)]) (let ([locs (ssl-default-verify-sources)])
(define (reset) (define (reset)
(let* ([now (current-seconds)] (let* ([now (current-seconds)]
@ -663,10 +663,10 @@
[else (reset)])] [else (reset)])]
[else (reset)])))) [else (reset)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SSL ports ;; SSL ports
(define (mzssl-release mzssl) (define (mzssl-release mzssl)
;; Lock must be held ;; Lock must be held
(set-mzssl-refcount! mzssl (sub1 (mzssl-refcount mzssl))) (set-mzssl-refcount! mzssl (sub1 (mzssl-refcount mzssl)))
(when (zero? (mzssl-refcount mzssl)) (when (zero? (mzssl-refcount mzssl))
@ -675,7 +675,7 @@
(close-input-port (mzssl-i mzssl)) (close-input-port (mzssl-i mzssl))
(close-output-port (mzssl-o mzssl))))) (close-output-port (mzssl-o mzssl)))))
(define (pump-input-once mzssl need-progress?/out) (define (pump-input-once mzssl need-progress?/out)
(let ([buffer (mzssl-buffer mzssl)] (let ([buffer (mzssl-buffer mzssl)]
[i (mzssl-i mzssl)] [i (mzssl-i mzssl)]
[r-bio (mzssl-r-bio mzssl)]) [r-bio (mzssl-r-bio mzssl)])
@ -698,7 +698,7 @@
((mzssl-error mzssl) 'pump-input-once "couldn't write all bytes to BIO!")) ((mzssl-error mzssl) 'pump-input-once "couldn't write all bytes to BIO!"))
m)])))) m)]))))
(define (pump-output-once mzssl need-progress? output-blocked-result) (define (pump-output-once mzssl need-progress? output-blocked-result)
(let ([buffer (mzssl-buffer mzssl)] (let ([buffer (mzssl-buffer mzssl)]
[pipe-r (mzssl-pipe-r mzssl)] [pipe-r (mzssl-pipe-r mzssl)]
[pipe-w (mzssl-pipe-w mzssl)] [pipe-w (mzssl-pipe-w mzssl)]
@ -722,16 +722,16 @@
(port-commit-peeked n (port-progress-evt pipe-r) always-evt pipe-r) (port-commit-peeked n (port-progress-evt pipe-r) always-evt pipe-r)
#t))))))) #t)))))))
;; result is #t if there's more data to send out the ;; result is #t if there's more data to send out the
;; underlying output port, but the port is full ;; underlying output port, but the port is full
(define (pump-output mzssl) (define (pump-output mzssl)
(let ([v (pump-output-once mzssl #f 'blocked)]) (let ([v (pump-output-once mzssl #f 'blocked)])
(if (eq? v 'blocked) (if (eq? v 'blocked)
#t #t
(and v (and v
(pump-output mzssl))))) (pump-output mzssl)))))
(define (make-ssl-input-port mzssl) (define (make-ssl-input-port mzssl)
;; If SSL_read produces NEED_READ or NEED_WRITE, then the next ;; If SSL_read produces NEED_READ or NEED_WRITE, then the next
;; call to SSL_read must use the same arguments. ;; call to SSL_read must use the same arguments.
;; Use xfer-buffer so we have a consistent buffer to use with ;; Use xfer-buffer so we have a consistent buffer to use with
@ -841,7 +841,7 @@
(set-mzssl-r-closed?! mzssl #t) (set-mzssl-r-closed?! mzssl #t)
(mzssl-release mzssl)))))))) (mzssl-release mzssl))))))))
(define (flush-ssl mzssl enable-break?) (define (flush-ssl mzssl enable-break?)
;; Make sure that this SSL connection has said everything that it ;; Make sure that this SSL connection has said everything that it
;; wants to say --- that is, move data from the SLL output to the ;; wants to say --- that is, move data from the SLL output to the
;; underlying output port. Depending on the transport, the other end ;; underlying output port. Depending on the transport, the other end
@ -862,13 +862,13 @@
((if enable-break? sync/enable-break sync) (mzssl-o mzssl) (mzssl-i mzssl))) ((if enable-break? sync/enable-break sync) (mzssl-o mzssl) (mzssl-i mzssl)))
(loop))))))) (loop)))))))
(define (kernel-thread thunk) (define (kernel-thread thunk)
;; Since we provide #f to scheme_make_custodian, ;; Since we provide #f to scheme_make_custodian,
;; the custodian is managed directly by the root: ;; the custodian is managed directly by the root:
(parameterize ([current-custodian (scheme_make_custodian #f)]) (parameterize ([current-custodian (scheme_make_custodian #f)])
(thread thunk))) (thread thunk)))
(define (make-ssl-output-port mzssl) (define (make-ssl-output-port mzssl)
;; If SSL_write produces NEED_READ or NEED_WRITE, then the next ;; If SSL_write produces NEED_READ or NEED_WRITE, then the next
;; call to SSL_write must use the same arguments. ;; call to SSL_write must use the same arguments.
;; Use xfer-buffer so we have a consistent buffer to use with ;; Use xfer-buffer so we have a consistent buffer to use with
@ -1077,7 +1077,7 @@
[() buffer-mode] [() buffer-mode]
[(mode) (set! buffer-mode mode)])))) [(mode) (set! buffer-mode mode)]))))
(define (ports->ssl-ports i o (define (ports->ssl-ports i o
#:context [context #f] #:context [context #f]
#:encrypt [encrypt default-encrypt] #:encrypt [encrypt default-encrypt]
#:mode [mode 'connect] #:mode [mode 'connect]
@ -1089,7 +1089,7 @@
close-original? shutdown-on-close? error/ssl close-original? shutdown-on-close? error/ssl
hostname)) hostname))
(define (create-ssl who context-or-encrypt-method connect/accept error/ssl) (define (create-ssl who context-or-encrypt-method connect/accept error/ssl)
(define connect? (define connect?
(case connect/accept (case connect/accept
[(connect) #t] [(connect) #t]
@ -1130,7 +1130,7 @@
(set! free-bio? #f) (set! free-bio? #f)
(values ssl r-bio w-bio connect?))))))))) (values ssl r-bio w-bio connect?)))))))))
(define (wrap-ports who i o context-or-encrypt-method connect/accept (define (wrap-ports who i o context-or-encrypt-method connect/accept
close? shutdown-on-close? error/ssl close? shutdown-on-close? error/ssl
hostname) hostname)
(unless (input-port? i) (unless (input-port? i)
@ -1188,30 +1188,30 @@
(values (register (make-ssl-input-port mzssl) mzssl #t) (values (register (make-ssl-input-port mzssl) mzssl #t)
(register (make-ssl-output-port mzssl) mzssl #f)))))) (register (make-ssl-output-port mzssl) mzssl #f))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SSL port registry ;; SSL port registry
(define ssl-ports (make-weak-hasheq)) (define ssl-ports (make-weak-hasheq))
(define (register port mzssl input?) (define (register port mzssl input?)
(hash-set! ssl-ports port (make-ephemeron port (cons mzssl input?))) (hash-set! ssl-ports port (make-ephemeron port (cons mzssl input?)))
port) port)
(define (lookup who what port) (define (lookup who what port)
(let ([v (hash-ref ssl-ports port #f)]) (let ([v (hash-ref ssl-ports port #f)])
(unless v (unless v
(raise-argument-error who what port)) (raise-argument-error who what port))
(let ([p (ephemeron-value v)]) (let ([p (ephemeron-value v)])
(values (car p) (cdr p))))) (values (car p) (cdr p)))))
(define (ssl-addresses p [port-numbers? #f]) (define (ssl-addresses p [port-numbers? #f])
(let-values ([(mzssl input?) (lookup 'ssl-addresses "(or/c ssl-port? ssl-listener?)" p)]) (let-values ([(mzssl input?) (lookup 'ssl-addresses "(or/c ssl-port? ssl-listener?)" p)])
(tcp-addresses (if (eq? 'listener input?) (tcp-addresses (if (eq? 'listener input?)
(ssl-listener-l mzssl) (ssl-listener-l mzssl)
(if input? (mzssl-i mzssl) (mzssl-o mzssl))) (if input? (mzssl-i mzssl) (mzssl-o mzssl)))
port-numbers?))) port-numbers?)))
(define (ssl-abandon-port p) (define (ssl-abandon-port p)
(let-values ([(mzssl input?) (lookup 'ssl-abandon-port "(and/c ssl-port? output-port?)" p)]) (let-values ([(mzssl input?) (lookup 'ssl-abandon-port "(and/c ssl-port? output-port?)" p)])
(when input? (when input?
(raise-argument-error 'ssl-abandon-port "(and/c ssl-port? output-port?)" p)) (raise-argument-error 'ssl-abandon-port "(and/c ssl-port? output-port?)" p))
@ -1219,47 +1219,47 @@
;; Call close-output-port to flush, shutdown, and decrement mzssl refcount. ;; Call close-output-port to flush, shutdown, and decrement mzssl refcount.
(close-output-port p))) (close-output-port p)))
(define (ssl-peer-verified? p) (define (ssl-peer-verified? p)
(let-values ([(mzssl input?) (lookup 'ssl-peer-verified? "ssl-port?" p)]) (let-values ([(mzssl input?) (lookup 'ssl-peer-verified? "ssl-port?" p)])
(and (eq? X509_V_OK (SSL_get_verify_result (mzssl-ssl mzssl))) (and (eq? X509_V_OK (SSL_get_verify_result (mzssl-ssl mzssl)))
(SSL_get_peer_certificate (mzssl-ssl mzssl)) (SSL_get_peer_certificate (mzssl-ssl mzssl))
#t))) #t)))
(define (ssl-peer-subject-name p) (define (ssl-peer-subject-name p)
(let ([cert (ssl-port->cert 'ssl-peer-subject-name p)]) (let ([cert (ssl-port->cert 'ssl-peer-subject-name p)])
(if cert (if cert
(let ([bytes (make-bytes 1024 0)]) (let ([bytes (make-bytes 1024 0)])
(X509_NAME_oneline (X509_get_subject_name cert) bytes (bytes-length bytes))) (X509_NAME_oneline (X509_get_subject_name cert) bytes (bytes-length bytes)))
#f))) #f)))
(define (ssl-peer-issuer-name p) (define (ssl-peer-issuer-name p)
(let ([cert (ssl-port->cert 'ssl-peer-subject-name p)]) (let ([cert (ssl-port->cert 'ssl-peer-subject-name p)])
(if cert (if cert
(let ([bytes (make-bytes 1024 0)]) (let ([bytes (make-bytes 1024 0)])
(X509_NAME_oneline (X509_get_issuer_name cert) bytes (bytes-length bytes))) (X509_NAME_oneline (X509_get_issuer_name cert) bytes (bytes-length bytes)))
#f))) #f)))
;; ssl-peer-certificate-hostnames : ssl-port -> (listof string) ;; ssl-peer-certificate-hostnames : ssl-port -> (listof string)
(define (ssl-peer-certificate-hostnames p) (define (ssl-peer-certificate-hostnames p)
(let ([cert (ssl-port->cert 'ssl-peer-certificate-hostnames p)]) (let ([cert (ssl-port->cert 'ssl-peer-certificate-hostnames p)])
(if cert (cert->names cert) null))) (if cert (cert->names cert) null)))
;; ssl-peer-check-hostname : ssl-port string -> boolean ;; ssl-peer-check-hostname : ssl-port string -> boolean
(define (ssl-peer-check-hostname p hostname) (define (ssl-peer-check-hostname p hostname)
(let ([cert (ssl-port->cert 'ssl-peer-check-hostname p)]) (let ([cert (ssl-port->cert 'ssl-peer-check-hostname p)])
(hostname-in-cert? hostname cert))) (hostname-in-cert? hostname cert)))
;; ssl-port->cert : symbol ssl-port -> Cert/#f ;; ssl-port->cert : symbol ssl-port -> Cert/#f
(define (ssl-port->cert who p) (define (ssl-port->cert who p)
(let-values ([(mzssl _input?) (lookup who "ssl-port?" p)]) (let-values ([(mzssl _input?) (lookup who "ssl-port?" p)])
(SSL_get_peer_certificate (mzssl-ssl mzssl)))) (SSL_get_peer_certificate (mzssl-ssl mzssl))))
;; hostname-in-cert? : string Cert -> boolean ;; hostname-in-cert? : string Cert -> boolean
(define (hostname-in-cert? hostname cert) (define (hostname-in-cert? hostname cert)
(for/or ([cert-hostname (in-list (cert->names cert))]) (for/or ([cert-hostname (in-list (cert->names cert))])
(check-hostname hostname cert-hostname))) (check-hostname hostname cert-hostname)))
(define (cert->names cert) (define (cert->names cert)
;; RFC 2818 (section 3.1) says use subjectAltName dNSName extensions ;; RFC 2818 (section 3.1) says use subjectAltName dNSName extensions
;; if present, else use final commonName entry. ;; if present, else use final commonName entry.
(let ([names (cert->altnames cert)]) (let ([names (cert->altnames cert)])
@ -1267,7 +1267,7 @@
[else (let ([name (cert->name cert)]) [else (let ([name (cert->name cert)])
(if name (list name) null))]))) (if name (list name) null))])))
(define (cert->name cert) (define (cert->name cert)
;; Returns commonName DNS name if exists, #f otherwise. ;; Returns commonName DNS name if exists, #f otherwise.
(let* ([name (X509_get_subject_name cert)] (let* ([name (X509_get_subject_name cert)]
[last-cn-index [last-cn-index
@ -1281,7 +1281,7 @@
[asn1str (X509_NAME_ENTRY_get_data entry)]) [asn1str (X509_NAME_ENTRY_get_data entry)])
(asn1string->bytes asn1str))]))) (asn1string->bytes asn1str))])))
(define (asn1string->bytes asn1str) (define (asn1string->bytes asn1str)
(let* ([len (ASN1_STRING_length asn1str)] (let* ([len (ASN1_STRING_length asn1str)]
[data (ASN1_STRING_data asn1str)] [data (ASN1_STRING_data asn1str)]
[buf (make-bytes len 0)]) [buf (make-bytes len 0)])
@ -1289,7 +1289,7 @@
;; FIXME: detect UTF-8 strings? ;; FIXME: detect UTF-8 strings?
(bytes->string/latin-1 buf))) (bytes->string/latin-1 buf)))
(define (cert->altnames cert) (define (cert->altnames cert)
;; Returns list of DNS names in subjectAltName extension ;; Returns list of DNS names in subjectAltName extension
;; FIXME: also return IP addresses? ;; FIXME: also return IP addresses?
;; Reference: curl-7.28.0/lib/ssluse.c verifyhost() ;; Reference: curl-7.28.0/lib/ssluse.c verifyhost()
@ -1307,32 +1307,32 @@
(when namestack (sk_pop_free namestack GENERAL_NAME_free)) (when namestack (sk_pop_free namestack GENERAL_NAME_free))
names)) names))
(define (check-hostname cx-name cert-name-pattern) (define (check-hostname cx-name cert-name-pattern)
(let* ([cx-parts (string-split cx-name "." #:trim? #f)] (let* ([cx-parts (string-split cx-name "." #:trim? #f)]
[cert-parts (string-split cert-name-pattern "." #:trim? #f)]) [cert-parts (string-split cert-name-pattern "." #:trim? #f)])
(and (equal? (length cx-parts) (and (equal? (length cx-parts)
(length cert-parts)) (length cert-parts))
(andmap check-hostname-part cx-parts cert-parts)))) (andmap check-hostname-part cx-parts cert-parts))))
(define (check-hostname-part cx-part cert-part) (define (check-hostname-part cx-part cert-part)
(cond [(equal? cert-part "*") (cond [(equal? cert-part "*")
#t] #t]
[(for/or ([c (in-string cert-part)]) (eqv? c #\*)) [(for/or ([c (in-string cert-part)]) (eqv? c #\*))
(regexp-match? (glob->regexp cert-part) cx-part)] (regexp-match? (glob->regexp cert-part) cx-part)]
[else (string-ci=? cx-part cert-part)])) [else (string-ci=? cx-part cert-part)]))
(define (glob->regexp glob) (define (glob->regexp glob)
(let* ([lit-parts (string-split glob #rx"[*]" #:trim? #f)] (let* ([lit-parts (string-split glob #rx"[*]" #:trim? #f)]
[lit-rxs (for/list ([part (in-list lit-parts)]) (regexp-quote part #f))]) [lit-rxs (for/list ([part (in-list lit-parts)]) (regexp-quote part #f))])
(regexp (string-join lit-rxs ".*")))) (regexp (string-join lit-rxs ".*"))))
(define (ssl-port? v) (define (ssl-port? v)
(and (hash-ref ssl-ports v #f) #t)) (and (hash-ref ssl-ports v #f) #t))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SSL listen ;; SSL listen
(define (ssl-listen port-k (define (ssl-listen port-k
[queue-k 5] [reuse? #f] [hostname-or-#f #f] [queue-k 5] [reuse? #f] [hostname-or-#f #f]
[protocol-symbol-or-context default-encrypt]) [protocol-symbol-or-context default-encrypt])
(let* ([ctx (if (ssl-server-context? protocol-symbol-or-context) (let* ([ctx (if (ssl-server-context? protocol-symbol-or-context)
@ -1343,15 +1343,15 @@
[ssl-l (make-ssl-listener l ctx)]) [ssl-l (make-ssl-listener l ctx)])
(register ssl-l ssl-l 'listener))) (register ssl-l ssl-l 'listener)))
(define (ssl-close l) (define (ssl-close l)
(unless (ssl-listener? l) (unless (ssl-listener? l)
(raise-argument-error 'ssl-close "ssl-listener?" l)) (raise-argument-error 'ssl-close "ssl-listener?" l))
(tcp-close (ssl-listener-l l))) (tcp-close (ssl-listener-l l)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SSL accept ;; SSL accept
(define (do-ssl-accept who tcp-accept ssl-listener) (define (do-ssl-accept who tcp-accept ssl-listener)
(let-values ([(i o) (tcp-accept (ssl-listener-l ssl-listener))]) (let-values ([(i o) (tcp-accept (ssl-listener-l ssl-listener))])
;; Obviously, there's a race condition between accepting the ;; Obviously, there's a race condition between accepting the
;; connections and installing the exception handler below. However, ;; connections and installing the exception handler below. However,
@ -1365,16 +1365,16 @@
(raise exn))]) (raise exn))])
(wrap-ports who i o (ssl-listener-mzctx ssl-listener) 'accept #t #f error/network #f)))) (wrap-ports who i o (ssl-listener-mzctx ssl-listener) 'accept #t #f error/network #f))))
(define (ssl-accept ssl-listener) (define (ssl-accept ssl-listener)
(do-ssl-accept 'ssl-accept tcp-accept ssl-listener)) (do-ssl-accept 'ssl-accept tcp-accept ssl-listener))
(define (ssl-accept/enable-break ssl-listener) (define (ssl-accept/enable-break ssl-listener)
(do-ssl-accept 'ssl-accept/enable-break tcp-accept/enable-break ssl-listener)) (do-ssl-accept 'ssl-accept/enable-break tcp-accept/enable-break ssl-listener))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SSL connect ;; SSL connect
(define (do-ssl-connect who tcp-connect hostname port-k client-context-or-protocol-symbol) (define (do-ssl-connect who tcp-connect hostname port-k client-context-or-protocol-symbol)
(let-values ([(i o) (tcp-connect hostname port-k)]) (let-values ([(i o) (tcp-connect hostname port-k)])
;; See do-ssl-accept for note on race condition here: ;; See do-ssl-accept for note on race condition here:
(with-handlers ([void (lambda (exn) (with-handlers ([void (lambda (exn)
@ -1384,7 +1384,7 @@
(wrap-ports who i o client-context-or-protocol-symbol 'connect #t #f error/network (wrap-ports who i o client-context-or-protocol-symbol 'connect #t #f error/network
hostname)))) hostname))))
(define (ssl-connect (define (ssl-connect
hostname port-k hostname port-k
[client-context-or-protocol-symbol default-encrypt]) [client-context-or-protocol-symbol default-encrypt])
(do-ssl-connect 'ssl-connect (do-ssl-connect 'ssl-connect
@ -1393,7 +1393,7 @@
port-k port-k
client-context-or-protocol-symbol)) client-context-or-protocol-symbol))
(define (ssl-connect/enable-break (define (ssl-connect/enable-break
hostname port-k hostname port-k
[client-context-or-protocol-symbol default-encrypt]) [client-context-or-protocol-symbol default-encrypt])
(do-ssl-connect 'ssl-connect/enable-break (do-ssl-connect 'ssl-connect/enable-break
@ -1402,17 +1402,17 @@
port-k port-k
client-context-or-protocol-symbol)) client-context-or-protocol-symbol))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Initialization ;; Initialization
(define ssl-available? (and libssl #t)) (define ssl-available? (and libssl #t))
(define scheme_register_process_global (define scheme_register_process_global
(and ssl-available? (and ssl-available?
(get-ffi-obj 'scheme_register_process_global #f (_fun _string _pointer -> _pointer)))) (get-ffi-obj 'scheme_register_process_global #f (_fun _string _pointer -> _pointer))))
(when ssl-available? (when ssl-available?
;; Make sure only one place tries to initialize OpenSSL, ;; Make sure only one place tries to initialize OpenSSL,
;; and wait in case some other place is currently initializing ;; and wait in case some other place is currently initializing
;; it. ;; it.
@ -1433,4 +1433,4 @@
(SSL_library_init) (SSL_library_init)
(SSL_load_error_strings) (SSL_load_error_strings)
(scheme_register_process_global "OpenSSL-support-initialized" done) (scheme_register_process_global "OpenSSL-support-initialized" done)
(end-atomic))))))) (end-atomic))))))