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