Server certificate verification, lazy handshake for accept
parent
95358981e6
commit
b301858c67
|
@ -15,6 +15,8 @@ SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
|
|||
TUPLE: secure-config
|
||||
method
|
||||
key-file password
|
||||
verify
|
||||
verify-depth
|
||||
ca-file ca-path
|
||||
dh-file
|
||||
ephemeral-key-bits ;
|
||||
|
@ -22,7 +24,9 @@ ephemeral-key-bits ;
|
|||
: <secure-config> ( -- config )
|
||||
secure-config new
|
||||
SSLv23 >>method
|
||||
1024 >>ephemeral-key-bits ;
|
||||
1024 >>ephemeral-key-bits
|
||||
! "resource:extra/openssl/cacert.pem" >>ca-file
|
||||
t >>verify ;
|
||||
|
||||
TUPLE: secure-context config handle disposed ;
|
||||
|
||||
|
|
|
@ -44,8 +44,8 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
|
|||
[ ] [
|
||||
[
|
||||
drop
|
||||
input-stream get stream>> handle>> f >>connected drop
|
||||
"hello" write flush
|
||||
input-stream get stream>> handle>> f >>connected drop
|
||||
] server-test
|
||||
] unit-test
|
||||
|
||||
|
@ -55,7 +55,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
|
|||
! actually an invalid certificate
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [ [ drop ] server-test ] unit-test
|
||||
[ ] [ [ drop "hi" write ] server-test ] unit-test
|
||||
|
||||
[
|
||||
<secure-config> [
|
||||
|
@ -97,54 +97,58 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
|
|||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop dispose
|
||||
accept drop dup stream-read1 drop dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
|
||||
! Client socket shutdown timeout
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop 1 minutes sleep dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] "Silly server" spawn drop
|
||||
] unit-test
|
||||
|
||||
! Until I sort out two-stage handshaking, I can't do much here
|
||||
[
|
||||
1 seconds secure-socket-timeout [
|
||||
<secure-config> [
|
||||
"127.0.0.1" "port" get ?promise <inet4> <secure>
|
||||
ascii <client> drop dispose
|
||||
] with-secure-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
|
||||
! Server socket shutdown timeout
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop 1 minutes sleep dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] "Silly server" spawn drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
1 seconds secure-socket-timeout [
|
||||
<secure-config> [
|
||||
"127.0.0.1" "port" get ?promise <inet4> <secure>
|
||||
ascii <client> drop dispose
|
||||
] with-secure-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
|
||||
! Server socket shutdown timeout
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"127.0.0.1" "port" get ?promise
|
||||
<inet4> <secure> ascii <client> drop 1 minutes sleep dispose
|
||||
] with-test-context
|
||||
] "Silly client" spawn drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
1 seconds secure-socket-timeout [
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
[
|
||||
"127.0.0.1" "port" get ?promise
|
||||
<inet4> <secure> ascii <client> drop 1 minutes sleep dispose
|
||||
] with-test-context
|
||||
] "Silly client" spawn drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
1 seconds secure-socket-timeout [
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
] drop
|
||||
|
|
|
@ -22,6 +22,26 @@ M: ssl-handle handle-fd file>> handle-fd ;
|
|||
nip (ssl-error)
|
||||
] if ;
|
||||
|
||||
: check-accept-response ( handle r -- event )
|
||||
over handle>> over SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_NONE [ 2drop f ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
: do-ssl-accept ( ssl-handle -- )
|
||||
dup dup handle>> SSL_accept check-accept-response dup
|
||||
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
|
||||
|
||||
: maybe-handshake ( ssl-handle -- )
|
||||
dup connected>> [ drop ] [
|
||||
t >>connected
|
||||
[ do-ssl-accept ] with-timeout
|
||||
] if ;
|
||||
|
||||
: check-response ( port r -- port r n )
|
||||
over handle>> handle>> over SSL_get_error ; inline
|
||||
|
||||
|
@ -38,6 +58,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
|
|||
} case ;
|
||||
|
||||
M: ssl-handle refill
|
||||
dup maybe-handshake
|
||||
handle>> ! ssl
|
||||
over buffer>>
|
||||
[ buffer-end ] ! buf
|
||||
|
@ -57,6 +78,7 @@ M: ssl-handle refill
|
|||
} case ;
|
||||
|
||||
M: ssl-handle drain
|
||||
dup maybe-handshake
|
||||
handle>> ! ssl
|
||||
over buffer>>
|
||||
[ buffer@ ] ! buf
|
||||
|
@ -107,52 +129,25 @@ M: secure establish-connection ( client-out remote -- )
|
|||
|
||||
M: secure (server) addrspec>> (server) ;
|
||||
|
||||
: check-accept-response ( handle r -- event )
|
||||
M: secure (accept)
|
||||
[
|
||||
addrspec>> (accept) >r |dispose <ssl-socket> r>
|
||||
] with-destructors ;
|
||||
|
||||
: check-shutdown-response ( handle r -- event )
|
||||
#! We don't do two-step shutdown here because I couldn't
|
||||
#! figure out how to do it with non-blocking BIOs. Also, it
|
||||
#! seems that SSL_shutdown always returns 0 -- this sounds
|
||||
#! like a bug
|
||||
over handle>> over SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_NONE [ 2drop f ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SYSCALL [ dup zero? [ 2drop f ] [ syscall-error ] if ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
: do-ssl-accept ( ssl-handle -- )
|
||||
dup dup handle>> SSL_accept check-accept-response dup
|
||||
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
|
||||
|
||||
M: secure (accept)
|
||||
[
|
||||
addrspec>> (accept) >r
|
||||
|dispose <ssl-socket> t >>connected |dispose
|
||||
dup [ do-ssl-accept ] with-timeout r>
|
||||
] with-destructors ;
|
||||
|
||||
: check-shutdown-response ( handle r -- event )
|
||||
#! SSL_shutdown always returns 0 due to openssl bugs?
|
||||
{
|
||||
{ 1 [ drop f ] }
|
||||
{ 0 [
|
||||
dup handle>> dup f 0 SSL_read 2dup SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_ZERO_RETURN [ 3drop +retry+ ] }
|
||||
{ SSL_ERROR_WANT_READ [ 3drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 3drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case
|
||||
] }
|
||||
{ -1 [
|
||||
handle>> -1 SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_WANT_READ [ +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ -1 syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case
|
||||
] }
|
||||
} case ;
|
||||
|
||||
: (shutdown) ( handle -- )
|
||||
dup dup handle>> SSL_shutdown check-shutdown-response
|
||||
dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ;
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -122,6 +122,11 @@ FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ;
|
|||
|
||||
FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ;
|
||||
|
||||
: SSL_SENT_SHUTDOWN 1 ;
|
||||
: SSL_RECEIVED_SHUTDOWN 2 ;
|
||||
|
||||
FUNCTION: int SSL_get_shutdown ( ssl-pointer ssl ) ;
|
||||
|
||||
FUNCTION: void SSL_free ( ssl-pointer ssl ) ;
|
||||
|
||||
FUNCTION: int SSL_want ( ssl-pointer ssl ) ;
|
||||
|
@ -151,6 +156,15 @@ FUNCTION: int SSL_use_certificate_file ( ssl-pointer ssl,
|
|||
FUNCTION: int SSL_CTX_load_verify_locations ( ssl-ctx ctx, char* CAfile,
|
||||
char* CApath ) ;
|
||||
|
||||
FUNCTION: int SSL_CTX_set_default_verify_paths ( ssl-ctx ctx ) ;
|
||||
|
||||
: SSL_VERIFY_NONE 0 ; inline
|
||||
: SSL_VERIFY_PEER 1 ; inline
|
||||
: SSL_VERIFY_FAIL_IF_NO_PEER_CERT 2 ; inline
|
||||
: SSL_VERIFY_CLIENT_ONCE 4 ; inline
|
||||
|
||||
FUNCTION: void SSL_CTX_set_verify ( ssl-ctx ctx, int mode, void* callback ) ;
|
||||
|
||||
FUNCTION: void SSL_CTX_set_client_CA_list ( ssl-ctx ctx, ssl-pointer list ) ;
|
||||
|
||||
FUNCTION: ssl-pointer SSL_load_client_CA_file ( char* file ) ;
|
||||
|
|
|
@ -94,11 +94,14 @@ TUPLE: openssl-context < secure-context aliens ;
|
|||
[ ca-file>> dup [ (normalize-path) ] when ]
|
||||
[ ca-path>> dup [ (normalize-path) ] when ] bi
|
||||
] bi
|
||||
SSL_CTX_load_verify_locations ssl-error
|
||||
] [ drop ] if ;
|
||||
SSL_CTX_load_verify_locations
|
||||
] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
|
||||
|
||||
: set-verify-depth ( ctx -- )
|
||||
handle>> 1 SSL_CTX_set_verify_depth ;
|
||||
dup config>> verify-depth>> [
|
||||
[ handle>> ] [ config>> verify-depth>> ] bi
|
||||
SSL_CTX_set_verify_depth
|
||||
] [ drop ] if ;
|
||||
|
||||
TUPLE: bio handle disposed ;
|
||||
|
||||
|
@ -154,11 +157,6 @@ M: openssl-context dispose*
|
|||
|
||||
TUPLE: ssl-handle file handle connected disposed ;
|
||||
|
||||
ERROR: no-secure-context ;
|
||||
|
||||
M: no-secure-context summary
|
||||
drop "Secure socket operations must be wrapped in calls to with-secure-context" ;
|
||||
|
||||
SYMBOL: default-secure-context
|
||||
|
||||
: context-expired? ( context -- ? )
|
||||
|
@ -195,9 +193,11 @@ M: ssl-handle dispose*
|
|||
[ 2drop ] [ common-name-verify-error ] if ;
|
||||
|
||||
M: openssl check-certificate ( host ssl -- )
|
||||
handle>>
|
||||
[ nip check-verify-result ]
|
||||
[ check-common-name ]
|
||||
2bi ;
|
||||
current-secure-context config>> verify>> [
|
||||
handle>>
|
||||
[ nip check-verify-result ]
|
||||
[ check-common-name ]
|
||||
2bi
|
||||
] [ 2drop ] if ;
|
||||
|
||||
openssl secure-socket-backend set-global
|
||||
|
|
|
@ -1,3 +1,2 @@
|
|||
enterprise
|
||||
network
|
||||
bindings
|
||||
|
|
Loading…
Reference in New Issue