getting close to a working replacement for mzssl
svn: r2730
This commit is contained in:
Matthew Flatt
parent
489519f5ed
commit
d186dab805
|
|
@ -2,39 +2,71 @@
|
|||
;; This is a re-implementation of "mzssl.c" using `(lib "foreign.ss")'.
|
||||
;; It will soon replace "mzssl.c".
|
||||
|
||||
;; Warn clients: even when a (non-blocking) write fails to write all
|
||||
;; the data, the stream is committed to writing the given data in
|
||||
;; the future. (This requirement comes from the SSL library.)
|
||||
|
||||
(module mzssl2 mzscheme
|
||||
(require (lib "foreign.ss")
|
||||
(lib "port.ss")
|
||||
(lib "etc.ss"))
|
||||
|
||||
(provide ssl-make-client-context
|
||||
ports->ssl-ports)
|
||||
(provide ssl-available?
|
||||
|
||||
ssl-make-client-context
|
||||
ssl-make-server-context
|
||||
ssl-client-context?
|
||||
ssl-server-context?
|
||||
ssl-context?
|
||||
|
||||
ssl-load-certificate-chain!
|
||||
ssl-load-private-key!
|
||||
ssl-load-verify-root-certificates!
|
||||
ssl-load-suggested-certificate-authorities!
|
||||
ssl-set-verify!
|
||||
|
||||
ports->ssl-ports
|
||||
|
||||
ssl-listen
|
||||
ssl-close
|
||||
ssl-accept
|
||||
ssl-accept/enable-break
|
||||
ssl-connect
|
||||
ssl-connect/enable-break)
|
||||
|
||||
(unsafe!)
|
||||
|
||||
(define libssl (ffi-lib "libssl"))
|
||||
(define libssl (with-handlers ([exn:fail? (lambda (x) #f)])
|
||||
(ffi-lib "libssl")))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; SSL bindings and constants
|
||||
|
||||
(define-syntax define-define-X
|
||||
(syntax-rules ()
|
||||
[(_ id lib)
|
||||
[(_ id chk lib)
|
||||
(define-syntax (id stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id type)
|
||||
(with-syntax ([str (symbol->string (syntax-e #'id))])
|
||||
#'(define id
|
||||
(get-ffi-obj str lib (_fun . type))))]))]))
|
||||
(and chk
|
||||
(get-ffi-obj str lib (_fun . type)))))]))]))
|
||||
|
||||
(define-define-X define-ssl libssl)
|
||||
(define-define-X define-mzscheme #f)
|
||||
(define-define-X define-ssl libssl libssl)
|
||||
(define-define-X define-mzscheme #t #f)
|
||||
|
||||
(define-fun-syntax _BIO_METHOD* (syntax-id-rules () [_ _pointer]))
|
||||
(define-fun-syntax _BIO* (syntax-id-rules () [_ _pointer]))
|
||||
(define-fun-syntax _SSL_METHOD* (syntax-id-rules () [_ _pointer]))
|
||||
(define-fun-syntax _SSL_CTX* (syntax-id-rules () [_ _pointer]))
|
||||
(define-fun-syntax _SSL* (syntax-id-rules () [_ _pointer]))
|
||||
(define-syntax typedef
|
||||
(syntax-rules ()
|
||||
[(_ id t)
|
||||
(define-fun-syntax id (syntax-id-rules () [_ t]))]))
|
||||
|
||||
(typedef _BIO_METHOD* _pointer)
|
||||
(typedef _BIO* _pointer)
|
||||
(typedef _SSL_METHOD* _pointer)
|
||||
(typedef _SSL_CTX* _pointer)
|
||||
(typedef _SSL* _pointer)
|
||||
(typedef _X509_NAME* _pointer)
|
||||
|
||||
(define-ssl SSLv2_client_method (-> _SSL_METHOD*))
|
||||
(define-ssl SSLv2_server_method (-> _SSL_METHOD*))
|
||||
|
|
@ -58,6 +90,14 @@
|
|||
(define-ssl SSL_CTX_new (_SSL_METHOD* -> _SSL_CTX*))
|
||||
(define-ssl SSL_CTX_free (_SSL_CTX* -> _void))
|
||||
|
||||
(define-ssl SSL_CTX_set_verify (_SSL_CTX* _int _pointer -> _void))
|
||||
(define-ssl SSL_CTX_use_certificate_chain_file (_SSL_CTX* _bytes -> _int))
|
||||
(define-ssl SSL_CTX_load_verify_locations (_SSL_CTX* _bytes -> _int))
|
||||
(define-ssl SSL_CTX_set_client_CA_list (_SSL_CTX* _X509_NAME* -> _int))
|
||||
(define-ssl SSL_CTX_use_RSAPrivateKey_file (_SSL_CTX* _bytes _int -> _int))
|
||||
(define-ssl SSL_CTX_use_PrivateKey_file (_SSL_CTX* _bytes _int -> _int))
|
||||
(define-ssl SSL_load_client_CA_file (_bytes -> _X509_NAME*))
|
||||
|
||||
(define-ssl SSL_new (_SSL_CTX* -> _SSL*))
|
||||
(define-ssl SSL_set_bio (_SSL* _BIO* _BIO* -> _void))
|
||||
(define-ssl SSL_connect (_SSL* -> _int))
|
||||
|
|
@ -82,6 +122,13 @@
|
|||
|
||||
(define BIO_C_SET_BUF_MEM_EOF_RETURN 130)
|
||||
|
||||
(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-mzscheme scheme_start_atomic (-> _void))
|
||||
(define-mzscheme scheme_end_atomic (-> _void))
|
||||
|
||||
|
|
@ -120,8 +167,19 @@
|
|||
(lambda () (scheme_end_atomic)))]))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Structs
|
||||
|
||||
(define-struct ssl-client-context (ctx))
|
||||
(define-struct ssl-context (ctx))
|
||||
(define-struct (ssl-client-context ssl-context) ())
|
||||
(define-struct (ssl-server-context ssl-context) ())
|
||||
|
||||
(define-struct ssl-listener (l mzctx))
|
||||
|
||||
;; internal:
|
||||
(define-struct mzssl (ssl i o r-bio w-bio pipe-r pipe-w buffer lock refcount))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Contexts, certificates, etc.
|
||||
|
||||
(define default-encrypt 'sslv2-or-v3)
|
||||
|
||||
|
|
@ -144,21 +202,101 @@
|
|||
(string-append also-expect "'sslv2-or-v3, 'sslv2, 'sslv3, or 'tls")
|
||||
e)])))
|
||||
|
||||
(define make-context
|
||||
(opt-lambda (who protocol-symbol also-expected client?)
|
||||
(let ([meth (encrypt->method who also-expected protocol-symbol client?)])
|
||||
(atomically ; so we reliably register the finalizer
|
||||
(let ([ctx (SSL_CTX_new meth)])
|
||||
(check-valid ctx who "context creation")
|
||||
(register-finalizer ctx (lambda (v) (SSL_CTX_free v)))
|
||||
((if client? make-ssl-client-context make-ssl-server-context) ctx))))))
|
||||
|
||||
(define ssl-make-client-context
|
||||
(opt-lambda ([protocol-symbol default-encrypt])
|
||||
(let ([meth (encrypt->method 'ssl-make-client-context "" protocol-symbol #t)])
|
||||
(atomically ; so we reliably regsiter the finalizer
|
||||
(let ([ctx (SSL_CTX_new meth)])
|
||||
(check-valid ctx 'ssl-make-client-context "context creation")
|
||||
(register-finalizer ctx (lambda (v) (SSL_CTX_free v)))
|
||||
(make-ssl-client-context ctx))))))
|
||||
(make-context 'ssl-make-client-context protocol-symbol "" #t)))
|
||||
|
||||
(define (get-context who context-or-encrypt-method)
|
||||
(if (ssl-client-context? context-or-encrypt-method)
|
||||
(ssl-client-context-ctx context-or-encrypt-method)
|
||||
(SSL_CTX_new (encrypt->method who "client context, " context-or-encrypt-method #t))))
|
||||
(define ssl-make-server-context
|
||||
(opt-lambda ([protocol-symbol default-encrypt])
|
||||
(make-context 'ssl-make-server-context protocol-symbol "" #f)))
|
||||
|
||||
(define-struct mzssl (ssl i o r-bio w-bio pipe-r pipe-w buffer lock refcount))
|
||||
(define (get-context who context-or-encrypt-method client?)
|
||||
(if (ssl-context? context-or-encrypt-method)
|
||||
(ssl-context-ctx context-or-encrypt-method)
|
||||
(SSL_CTX_new (encrypt->method who "context" context-or-encrypt-method client?))))
|
||||
|
||||
(define (get-context/listener who ssl-context-or-listener)
|
||||
(cond
|
||||
[(ssl-context? ssl-context-or-listener)
|
||||
(ssl-context-ctx ssl-context-or-listener)]
|
||||
[(ssl-listener? ssl-context-or-listener)
|
||||
(ssl-context-ctx (ssl-listener-mzctx ssl-context-or-listener))]
|
||||
[else
|
||||
(raise-type-error who
|
||||
"SSL context or listener"
|
||||
ssl-context-or-listener)]))
|
||||
|
||||
(define (ssl-load-... who load-it ssl-context-or-listener pathname)
|
||||
(let ([ctx (get-context/listener 'ssl-load-certificate-chain!
|
||||
ssl-context-or-listener)])
|
||||
(unless (path-string? pathname)
|
||||
(raise-type-error 'ssl-load-certificate-chain!
|
||||
"path or string"
|
||||
pathname))
|
||||
(let ([path (path->bytes
|
||||
(path->complete-path (expand-path pathname)
|
||||
(current-directory)))])
|
||||
(let ([n (load-it ctx path)])
|
||||
(unless (= n 1)
|
||||
(error who "load failed from: ~e ~a"
|
||||
pathname
|
||||
(get-error-message (ERR_get_error))))))))
|
||||
|
||||
(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-verify-root-certificates! ssl-context-or-listener pathname)
|
||||
(ssl-load-... 'ssl-load-verify-root-certificates!
|
||||
SSL_CTX_load_verify_locations
|
||||
ssl-context-or-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)])
|
||||
(if (ptr-equal? stk #f)
|
||||
0
|
||||
(begin
|
||||
(SSL_CTX_set_client_CA_list ctx stk)
|
||||
1))))
|
||||
ssl-listener pathname))
|
||||
|
||||
(define ssl-load-private-key!
|
||||
(opt-lambda (ssl-context-or-listener pathname [rsa? #t] [asn1? #f])
|
||||
(ssl-load-... 'ssl-load-private-key!
|
||||
(lambda (ctx path)
|
||||
((if rsa?
|
||||
SSL_CTX_use_RSAPrivateKey_file
|
||||
SSL_CTX_use_PrivateKey_file)
|
||||
ctx path
|
||||
(if asn1?
|
||||
SSL_FILETYPE_ASN1
|
||||
SSL_FILETYPE_PEM)))
|
||||
ssl-context-or-listener pathname)))
|
||||
|
||||
(define (ssl-set-verify! ssl-context-or-listener on?)
|
||||
(let ([ctx (get-context/listener 'ssl-set-verify!
|
||||
ssl-context-or-listener)])
|
||||
(SSL_CTX_set_verify ctx
|
||||
(if on?
|
||||
(bitwise-ior SSL_VERIFY_PEER
|
||||
SSL_VERIFY_FAIL_IF_NO_PEER_CERT)
|
||||
SSL_VERIFY_NONE)
|
||||
#f)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; SSL ports
|
||||
|
||||
(define (mzssl-release mzssl)
|
||||
(call-with-semaphore
|
||||
|
|
@ -183,7 +321,7 @@
|
|||
(error 'pump-input-once "couldn't write all bytes to BIO!"))
|
||||
m)]))))
|
||||
|
||||
(define (pump-output-once mzssl need-progress?)
|
||||
(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)]
|
||||
|
|
@ -199,16 +337,17 @@
|
|||
#f)
|
||||
(begin
|
||||
(write-bytes buffer pipe-w 0 n)
|
||||
(pump-output-once mzssl need-progress?))))
|
||||
(pump-output-once mzssl need-progress?
|
||||
output-blocked-result))))
|
||||
(let ([n ((if need-progress? write-bytes-avail write-bytes-avail*) buffer o 0 n)])
|
||||
(if (zero? n)
|
||||
#f
|
||||
output-blocked-result
|
||||
(begin
|
||||
(port-commit-peeked n (port-progress-evt pipe-r) always-evt pipe-r)
|
||||
#t)))))))
|
||||
|
||||
(define (pump-output mzssl)
|
||||
(when (pump-output-once mzssl #f)
|
||||
(when (pump-output-once mzssl #f #f)
|
||||
(pump-output mzssl)))
|
||||
|
||||
(define (make-ssl-input-port mzssl)
|
||||
|
|
@ -233,7 +372,7 @@
|
|||
(wrap-evt (mzssl-i mzssl) (lambda (x) 0))
|
||||
(do-read buffer)))]
|
||||
[(= err SSL_ERROR_WANT_WRITE)
|
||||
(if (pump-output-once mzssl #f)
|
||||
(if (pump-output-once mzssl #f #f)
|
||||
(do-read buffer)
|
||||
(wrap-evt (mzssl-o mzssl) (lambda (x) 0)))]
|
||||
[else
|
||||
|
|
@ -254,137 +393,218 @@
|
|||
(mzssl-release mzssl))))
|
||||
|
||||
(define (make-ssl-output-port mzssl)
|
||||
(make-output-port
|
||||
(format "SSL ~a" (object-name (mzssl-o mzssl)))
|
||||
(mzssl-o mzssl)
|
||||
;; write proc:
|
||||
(letrec ([do-write
|
||||
(lambda (buffer s e block-ok? enable-break?)
|
||||
(pump-output mzssl)
|
||||
(if (= s e)
|
||||
0
|
||||
(let ([n (SSL_write (mzssl-ssl mzssl)
|
||||
(if (zero? s)
|
||||
buffer
|
||||
(subbytes buffer s e))
|
||||
(- e s))])
|
||||
(if (n . > . 0)
|
||||
n
|
||||
(let ([err (SSL_get_error (mzssl-ssl mzssl) n)])
|
||||
(cond
|
||||
[(= err SSL_ERROR_WANT_READ)
|
||||
(let ([n (pump-input-once mzssl #f)])
|
||||
(if (eq? n 0)
|
||||
(wrap-evt (mzssl-i mzssl) (lambda (x) #f))
|
||||
(do-write buffer s e block-ok? enable-break?)))]
|
||||
[(= err SSL_ERROR_WANT_WRITE)
|
||||
(if (pump-output-once mzssl #f)
|
||||
(do-write buffer s e block-ok? enable-break?)
|
||||
(wrap-evt (mzssl-o mzssl) (lambda (x) #f)))]
|
||||
[else
|
||||
(error 'read-bytes "SSL read failed ~a"
|
||||
(get-error-message (ERR_get_error)))]))))))]
|
||||
[lock-unavailable
|
||||
(lambda () (wrap-evt (mzssl-lock mzssl) (lambda (x) #f)))])
|
||||
(lambda (buffer s e block-ok? enable-break?)
|
||||
(call-with-semaphore
|
||||
(mzssl-lock mzssl)
|
||||
do-write
|
||||
lock-unavailable
|
||||
buffer s e block-ok? enable-break?)))
|
||||
;; close proc:
|
||||
(lambda ()
|
||||
;; issue shutdown (i.e., EOF on read end)
|
||||
(let loop ()
|
||||
(pump-output mzssl)
|
||||
(let ([n (SSL_shutdown (mzssl-ssl mzssl))])
|
||||
(unless (= n 1)
|
||||
(let ([err (SSL_get_error (mzssl-ssl mzssl) n)])
|
||||
(cond
|
||||
[(= err SSL_ERROR_WANT_READ)
|
||||
(pump-input-once mzssl #t)
|
||||
(loop)]
|
||||
[(= err SSL_ERROR_WANT_WRITE)
|
||||
(pump-output-once mzssl #t)
|
||||
(loop)]
|
||||
[else
|
||||
(error 'read-bytes "SSL shutdown failed ~a"
|
||||
(get-error-message (ERR_get_error)))])))))
|
||||
(mzssl-release mzssl))))
|
||||
;; Need a consistent buffer to use with SSL_write
|
||||
;; across calls to the port's write function.
|
||||
(let ([xfer-buffer (make-bytes 512)])
|
||||
(make-output-port
|
||||
(format "SSL ~a" (object-name (mzssl-o mzssl)))
|
||||
(mzssl-o mzssl)
|
||||
;; write proc:
|
||||
(letrec ([do-write
|
||||
(lambda (len block-ok? enable-break?)
|
||||
(pump-output mzssl)
|
||||
(if (zero? len)
|
||||
;; Flush request; all data is in the the SSL
|
||||
;; stream, but how do we know that it's gone
|
||||
;; through the ports (which may involve both
|
||||
;; output and input)? It seems that making
|
||||
;; sure all output is gone is sufficient.
|
||||
;; We've already pumped output, but maybe some
|
||||
;; is stuck in the bio...
|
||||
(parameterize-break
|
||||
enable-break?
|
||||
(let loop ()
|
||||
(flush-output (mzssl-o mzssl))
|
||||
(when (pump-output-once mzssl #f #t)
|
||||
(loop)))
|
||||
0)
|
||||
;; Write request; even if blocking is ok, we treat
|
||||
;; it as non-blocking and let MzScheme handle blocking
|
||||
(let ([n (SSL_write (mzssl-ssl mzssl) xfer-buffer len)])
|
||||
(if (n . > . 0)
|
||||
n
|
||||
(let ([err (SSL_get_error (mzssl-ssl mzssl) n)])
|
||||
(cond
|
||||
[(= err SSL_ERROR_WANT_READ)
|
||||
(let ([n (pump-input-once mzssl #f)])
|
||||
(if (eq? n 0)
|
||||
(wrap-evt (mzssl-i mzssl) (lambda (x) #f))
|
||||
(do-write len block-ok? enable-break?)))]
|
||||
[(= err SSL_ERROR_WANT_WRITE)
|
||||
(if (pump-output-once mzssl #f #f)
|
||||
(do-write len block-ok? enable-break?)
|
||||
(wrap-evt (mzssl-o mzssl) (lambda (x) #f)))]
|
||||
[else
|
||||
(error 'read-bytes "SSL read failed ~a"
|
||||
(get-error-message (ERR_get_error)))]))))))]
|
||||
[top-write
|
||||
(lambda (buffer s e block-ok? enable-break?)
|
||||
(bytes-copy! xfer-buffer 0 buffer s e)
|
||||
(do-write (- e s) block-ok? enable-break?))]
|
||||
[lock-unavailable
|
||||
(lambda () (wrap-evt (mzssl-lock mzssl) (lambda (x) #f)))])
|
||||
(lambda (buffer s e block-ok? enable-break?)
|
||||
(call-with-semaphore
|
||||
(mzssl-lock mzssl)
|
||||
top-write
|
||||
lock-unavailable
|
||||
buffer s e block-ok? enable-break?)))
|
||||
;; close proc:
|
||||
(lambda ()
|
||||
;; issue shutdown (i.e., EOF on read end)
|
||||
(let loop ([cnt 1])
|
||||
(pump-output mzssl)
|
||||
(let ([n (SSL_shutdown (mzssl-ssl mzssl))])
|
||||
(if (= n 0)
|
||||
;; 0 seems to be the result in many cases because the socket
|
||||
;; is non-blocking, and then neither of the WANTs is returned.
|
||||
;; We address this by simply trying 10 times and then giving
|
||||
;; up. The two-step shutdown is optional, anyway.
|
||||
(unless (cnt . >= . 10)
|
||||
(loop (add1 cnt)))
|
||||
(unless (= n 1)
|
||||
(let ([err (SSL_get_error (mzssl-ssl mzssl) n)])
|
||||
(cond
|
||||
[(= err SSL_ERROR_WANT_READ)
|
||||
(pump-input-once mzssl #t)
|
||||
(loop)]
|
||||
[(= err SSL_ERROR_WANT_WRITE)
|
||||
(pump-output-once mzssl #t #f)
|
||||
(loop)]
|
||||
[else
|
||||
(error 'read-bytes "SSL shutdown failed ~a"
|
||||
(get-error-message (ERR_get_error)))]))))))
|
||||
(mzssl-release mzssl)))))
|
||||
|
||||
(define (ports->ssl-ports i o context-or-encrypt-method connect/accept close?)
|
||||
(let ([who 'input-port->ssl-input-port])
|
||||
(unless (input-port? i)
|
||||
(raise-type-error who "input port" i))
|
||||
(unless (output-port? o)
|
||||
(raise-type-error who "output port" o))
|
||||
(let ([ctx (get-context who context-or-encrypt-method)])
|
||||
(check-valid ctx who "context creation")
|
||||
(with-failure
|
||||
(lambda () (when (and ctx
|
||||
(symbol? context-or-encrypt-method))
|
||||
(SSL_CTX_free ctx)))
|
||||
(let ([connect? (case connect/accept
|
||||
[(connect) #t]
|
||||
[(accept) #f]
|
||||
[else
|
||||
(raise-type-error who "'connect or 'accept"
|
||||
connect/accept)])]
|
||||
[r-bio (BIO_new (BIO_s_mem))]
|
||||
[w-bio (BIO_new (BIO_s_mem))]
|
||||
[free-bio? #t])
|
||||
(with-failure
|
||||
(lambda () (when free-bio?
|
||||
(BIO_free r-bio)
|
||||
(BIO_free w-bio)))
|
||||
(let ([ssl (SSL_new ctx)])
|
||||
(check-valid ssl who "ssl setup")
|
||||
;; ssl has a ref count on ctx, so release:
|
||||
(when (symbol? context-or-encrypt-method)
|
||||
(SSL_CTX_free ctx)
|
||||
(set! ctx #f))
|
||||
(with-failure
|
||||
(lambda () (SSL_free ssl))
|
||||
(SSL_set_bio ssl r-bio w-bio)
|
||||
;; ssl has r-bio & w-bio (no ref count?), so drop it:
|
||||
(set! free-bio? #f)
|
||||
;; connect/accept:
|
||||
(let-values ([(buffer) (make-bytes 512)]
|
||||
[(pipe-r pipe-w) (make-pipe)])
|
||||
(let ([mzssl (make-mzssl ssl i o r-bio w-bio pipe-r pipe-w buffer (make-semaphore 1) 2)])
|
||||
(let loop ()
|
||||
(let ([status (if connect?
|
||||
(SSL_connect ssl)
|
||||
(SSL_accept ssl))])
|
||||
(pump-output mzssl)
|
||||
(when (status . < . 1)
|
||||
(let ([err (SSL_get_error ssl status)])
|
||||
(cond
|
||||
[(= err SSL_ERROR_WANT_READ)
|
||||
(let ([n (pump-input-once mzssl #t)])
|
||||
(when (eof-object? n)
|
||||
(error who "~a failed (input terminated prematurely)"
|
||||
(if connect? "connect" "accept"))))
|
||||
(loop)]
|
||||
[(= err SSL_ERROR_WANT_WRITE)
|
||||
(pump-output-once mzssl #t)
|
||||
(loop)]
|
||||
[else
|
||||
(error who "~a failed ~a"
|
||||
(if connect? "connect" "accept")
|
||||
(get-error-message (ERR_get_error)))])))))
|
||||
;; Connection complete; make ports
|
||||
(values (make-ssl-input-port mzssl)
|
||||
(make-ssl-output-port mzssl))))))))))))
|
||||
(wrap-ports 'port->ssl-ports i o context-or-encrypt-method connect/accept close?))
|
||||
|
||||
(define (wrap-ports who i o context-or-encrypt-method connect/accept close?)
|
||||
(unless (input-port? i)
|
||||
(raise-type-error who "input port" i))
|
||||
(unless (output-port? o)
|
||||
(raise-type-error who "output port" o))
|
||||
(let ([ctx (get-context who context-or-encrypt-method (eq? connect/accept 'connect))])
|
||||
(check-valid ctx who "context creation")
|
||||
(with-failure
|
||||
(lambda () (when (and ctx
|
||||
(symbol? context-or-encrypt-method))
|
||||
(SSL_CTX_free ctx)))
|
||||
(let ([connect? (case connect/accept
|
||||
[(connect) #t]
|
||||
[(accept) #f]
|
||||
[else
|
||||
(raise-type-error who "'connect or 'accept"
|
||||
connect/accept)])]
|
||||
[r-bio (BIO_new (BIO_s_mem))]
|
||||
[w-bio (BIO_new (BIO_s_mem))]
|
||||
[free-bio? #t])
|
||||
(with-failure
|
||||
(lambda () (when free-bio?
|
||||
(BIO_free r-bio)
|
||||
(BIO_free w-bio)))
|
||||
(unless (or (symbol? context-or-encrypt-method)
|
||||
(if connect?
|
||||
(ssl-client-context? context-or-encrypt-method)
|
||||
(ssl-server-context? context-or-encrypt-method)))
|
||||
(error who
|
||||
"'~a mode requires a ~a context, given: ~e"
|
||||
(if connect? 'connect 'accept)
|
||||
(if connect? "client" "server")
|
||||
context-or-encrypt-method))
|
||||
(let ([ssl (SSL_new ctx)])
|
||||
(check-valid ssl who "ssl setup")
|
||||
;; ssl has a ref count on ctx, so release:
|
||||
(when (symbol? context-or-encrypt-method)
|
||||
(SSL_CTX_free ctx)
|
||||
(set! ctx #f))
|
||||
(with-failure
|
||||
(lambda () (SSL_free ssl))
|
||||
(SSL_set_bio ssl r-bio w-bio)
|
||||
;; ssl has r-bio & w-bio (no ref count?), so drop it:
|
||||
(set! free-bio? #f)
|
||||
;; connect/accept:
|
||||
(let-values ([(buffer) (make-bytes 512)]
|
||||
[(pipe-r pipe-w) (make-pipe)])
|
||||
(let ([mzssl (make-mzssl ssl i o r-bio w-bio pipe-r pipe-w buffer (make-semaphore 1) 2)])
|
||||
(let loop ()
|
||||
(let ([status (if connect?
|
||||
(SSL_connect ssl)
|
||||
(SSL_accept ssl))])
|
||||
(pump-output mzssl)
|
||||
(when (status . < . 1)
|
||||
(let ([err (SSL_get_error ssl status)])
|
||||
(cond
|
||||
[(= err SSL_ERROR_WANT_READ)
|
||||
(let ([n (pump-input-once mzssl #t)])
|
||||
(when (eof-object? n)
|
||||
(error who "~a failed (input terminated prematurely)"
|
||||
(if connect? "connect" "accept"))))
|
||||
(loop)]
|
||||
[(= err SSL_ERROR_WANT_WRITE)
|
||||
(pump-output-once mzssl #t #f)
|
||||
(loop)]
|
||||
[else
|
||||
(error who "~a failed ~a"
|
||||
(if connect? "connect" "accept")
|
||||
(get-error-message (ERR_get_error)))])))))
|
||||
;; Connection complete; make ports
|
||||
(values (make-ssl-input-port mzssl)
|
||||
(make-ssl-output-port mzssl)))))))))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; SSL listen
|
||||
|
||||
(define ssl-listen
|
||||
(opt-lambda (port-k [queue-k 5] [reuse? #f] [hostname-or-#f #f] [protocol-symbol-or-context default-encrypt])
|
||||
(let ([ctx (cond
|
||||
[(ssl-server-context? protocol-symbol-or-context) protocol-symbol-or-context]
|
||||
[else (make-context 'ssl-listen protocol-symbol-or-context "server context, " #f)])])
|
||||
(let ([l (tcp-listen port-k queue-k reuse? hostname-or-#f)])
|
||||
(make-ssl-listener l ctx)))))
|
||||
|
||||
(define (ssl-close l)
|
||||
(unless (ssl-listener? l)
|
||||
(raise-type-error 'ssl-close "SSL listener" l))
|
||||
(tcp-close (ssl-listener-l l)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; SSL accept
|
||||
|
||||
(define (do-ssl-accept who tcp-accept ssl-listener)
|
||||
(let-values ([(i o) (tcp-accept (ssl-listener-l ssl-listener))])
|
||||
(wrap-ports who i o (ssl-listener-mzctx ssl-listener) 'accept #t)))
|
||||
|
||||
(define (ssl-accept ssl-listener)
|
||||
(do-ssl-accept 'ssl-accept tcp-accept ssl-listener))
|
||||
|
||||
(define (ssl-accept/enable-break ssl-listener)
|
||||
(do-ssl-accept 'ssl-accept/enable-break tcp-accept/enable-break ssl-listener))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; SSL connect
|
||||
|
||||
(define (do-ssl-connect who tcp-connect hostname port-k client-context-or-protocol-symbol)
|
||||
(let-values ([(i o) (tcp-connect hostname port-k)])
|
||||
(wrap-ports who i o client-context-or-protocol-symbol 'connect #t)))
|
||||
|
||||
(define ssl-connect
|
||||
(opt-lambda (hostname port-k [client-context-or-protocol-symbol default-encrypt])
|
||||
(do-ssl-connect 'ssl-connect tcp-connect hostname port-k
|
||||
client-context-or-protocol-symbol)))
|
||||
|
||||
(define ssl-connect/enable-break
|
||||
(opt-lambda (hostname port-k [client-context-or-protocol-symbol default-encrypt])
|
||||
(do-ssl-connect 'ssl-connect/enable-break tcp-connect/enable-break hostname port-k
|
||||
client-context-or-protocol-symbol)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Initialization
|
||||
|
||||
(SSL_library_init)
|
||||
(SSL_load_error_strings)
|
||||
(define ssl-available? (and libssl #t))
|
||||
|
||||
(when ssl-available?
|
||||
(SSL_library_init)
|
||||
(SSL_load_error_strings))
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user