steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix SSL shutdown

db4
Slava Pestov 2008-05-17 17:45:56 -05:00
parent b85096a24d
commit 1ecc54770e
10 changed files with 274 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
extra/io/server/server.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.sockets io.files io.streams.duplex logging
continuations destructors kernel math math.parser namespaces
parser sequences strings prettyprint debugger quotations
calendar threads concurrency.combinators assocs fry ;
USING: io io.sockets io.sockets.secure io.files
io.streams.duplex logging continuations destructors kernel math
math.parser namespaces parser sequences strings prettyprint
debugger quotations calendar threads concurrency.combinators
assocs fry ;
IN: io.server
SYMBOL: servers
@ -41,6 +42,9 @@ PRIVATE>
: internet-server ( port -- seq )
f swap t resolve-host ;
: secure-server ( port -- seq )
internet-server [ <secure> ] map ;
: with-server ( seq service encoding quot -- )
V{ } clone servers [
'[ , [ , , server-loop ] with-logging ] parallel-each

6
extra/io/sockets/secure/secure-tests.factor
View File

@ -1,5 +1 @@
IN: io.sockets.secure.tests
USING: io.sockets.secure tools.test ;
\ <ssl-config> must-infer
{ 1 0 } [ [ ] with-ssl-context ] must-infer-as
! No unit tests here, until Windows SSL is implemented

60
extra/io/sockets/secure/secure.factor
View File

@ -1,38 +1,68 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations
destructors io.sockets sequences ;
destructors io.sockets sequences inspector ;
IN: io.sockets.secure
SYMBOL: ssl-backend
SYMBOL: secure-socket-backend
SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
TUPLE: ssl-config method key-file ca-file ca-path password ;
TUPLE: secure-config
method
key-file password
ca-file ca-path
dh-file
ephemeral-key-bits ;
: <ssl-config> ( -- config )
ssl-config new
SSLv23 >>method ;
: <secure-config> ( -- config )
secure-config new
SSLv23 >>method
512 >>ephemeral-key-bits ;
TUPLE: ssl-context config handle ;
TUPLE: secure-context config handle disposed ;
HOOK: <ssl-context> ssl-backend ( config -- context )
HOOK: <secure-context> secure-socket-backend ( config -- context )
: with-ssl-context ( config quot -- )
: with-secure-context ( config quot -- )
[
[ <ssl-context> ] [ [ ssl-context set ] prepose ] bi*
[ <secure-context> ] [ [ secure-context set ] prepose ] bi*
with-disposal
] with-scope ; inline
TUPLE: ssl addrspec ;
TUPLE: secure addrspec ;
C: <ssl> ssl
C: <secure> secure
: resolve-secure-host ( host port passive? -- seq )
resolve-host [ <secure> ] map ;
HOOK: check-certificate secure-socket-backend ( host handle -- )
<PRIVATE
PREDICATE: ssl-inet < ssl addrspec>> inet? ;
PREDICATE: secure-inet < secure addrspec>> inet? ;
M: ssl-inet (client)
addrspec>> resolve-client-addr [ <ssl> ] map (client) ;
M: secure-inet (client)
[
addrspec>>
[ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep
host>> pick handle>> check-certificate
] with-destructors ;
PRIVATE>
ERROR: premature-close ;
M: premature-close summary
drop "Connection closed prematurely - potential truncation attack" ;
ERROR: certificate-verify-error result ;
M: certificate-verify-error summary
drop "Certificate verification failed" ;
ERROR: common-name-verify-error expected got ;
M: common-name-verify-error summary
drop "Common name verification failed" ;

7
extra/io/sockets/sockets.factor
View File

@ -217,7 +217,7 @@ TUPLE: datagram-port < port addr ;
HOOK: (datagram) io-backend ( addr -- datagram )
: <datagram> ( addr -- datagram )
: <datagram> ( addrspec -- datagram )
[
[ (datagram) |dispose ] keep
[ drop datagram-port <port> ] [ get-local-address ] 2bi
@ -287,11 +287,8 @@ TUPLE: inet host port ;
C: <inet> inet
: resolve-client-addr ( inet -- seq )
[ host>> ] [ port>> ] bi f resolve-host ;
M: inet (client)
resolve-client-addr (client) ;
[ host>> ] [ port>> ] bi f resolve-host (client) ;
ERROR: invalid-inet-server addrspec ;

90
extra/io/unix/sockets/secure/secure-tests.factor Normal file
View File

@ -0,0 +1,90 @@
IN: io.sockets.secure.tests
USING: accessors kernel namespaces io io.sockets
io.sockets.secure io.encodings.ascii io.streams.duplex
classes words destructors threads tools.test
concurrency.promises byte-arrays ;
\ <secure-config> must-infer
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
[ ] [ <promise> "port" set ] unit-test
[ ] [
[
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" >byte-array >>password
[
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
dup addr>> addrspec>> port>> "port" get fulfill
accept [
class word-name write
] curry with-stream
] with-disposal
] with-secure-context
] "SSL server test" spawn drop
] unit-test
[ "secure" ] [
<secure-config> [
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
] with-secure-context
] unit-test
! Now, see what happens if the server closes the connection prematurely
[ ] [ <promise> "port" set ] unit-test
[ ] [
[
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" >byte-array >>password
[
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
dup addr>> addrspec>> port>> "port" get fulfill
accept drop
[
dup in>> stream>> handle>> f >>connected drop
"hello" over stream-write dup stream-flush
] with-disposal
] with-disposal
] with-secure-context
] "SSL server test" spawn drop
] unit-test
[
<secure-config> [
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
] with-secure-context
] [ premature-close = ] must-fail-with
! Now, try validating the certificate. This should fail because its
! actually an invalid certificate
[ ] [ <promise> "port" set ] unit-test
[ ] [
[
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" >byte-array >>password
[
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
dup addr>> addrspec>> port>> "port" get fulfill
accept drop dispose
] with-disposal
] with-secure-context
] "SSL server test" spawn drop
] unit-test
[
<secure-config> [
"localhost" "port" get ?promise <inet> <secure> ascii
<client> drop dispose
] with-secure-context
] [ certificate-verify-error? ] must-fail-with

34
extra/io/unix/sockets/secure/secure.factor
View File

@ -6,7 +6,7 @@ continuations destructors
openssl openssl.libcrypto openssl.libssl
io.files io.ports io.unix.backend io.unix.sockets
io.encodings.ascii io.buffers io.sockets io.sockets.secure
unix system ;
unix system inspector ;
IN: io.unix.sockets.secure
M: ssl-handle handle-fd file>> handle-fd ;
@ -16,7 +16,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
drop
{
{ -1 [ (io-error) ] }
{ 0 [ "Premature EOF" throw ] }
{ 0 [ premature-close ] }
} case
] [
nip (ssl-error)
@ -26,7 +26,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
over handle>> handle>> over SSL_get_error ; inline
! Input ports
: check-read-response ( port r -- event )
: check-read-response ( port r -- event ) USING: namespaces io prettyprint ;
check-response
{
{ SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
@ -69,12 +69,12 @@ M: ssl-handle drain
[ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
[ handle>> swap dup SSL_set_bio ] keep ;
M: ssl ((client)) ( addrspec -- handle )
M: secure ((client)) ( addrspec -- handle )
addrspec>> ((client)) <ssl-socket> ;
M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ;
M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
M: ssl (get-local-address) addrspec>> (get-local-address) ;
M: secure (get-local-address) addrspec>> (get-local-address) ;
: check-connect-response ( port r -- event )
check-response
@ -91,13 +91,13 @@ M: ssl (get-local-address) addrspec>> (get-local-address) ;
check-connect-response dup
[ dupd wait-for-port do-ssl-connect ] [ 2drop ] if ;
M: ssl establish-connection ( client-out remote -- )
M: secure establish-connection ( client-out remote -- )
[ addrspec>> establish-connection ]
[ drop do-ssl-connect ]
[ drop handle>> t >>connected drop ]
2tri ;
M: ssl (server) addrspec>> (server) ;
M: secure (server) addrspec>> (server) ;
: check-accept-response ( handle r -- event )
over handle>> over SSL_get_error
@ -113,25 +113,27 @@ M: ssl (server) addrspec>> (server) ;
dup dup handle>> SSL_accept check-accept-response dup
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
M: ssl (accept)
M: secure (accept)
[
addrspec>> (accept) |dispose <ssl-socket> |dispose
dup do-ssl-accept
addrspec>> (accept) >r
|dispose <ssl-socket> t >>connected |dispose
dup do-ssl-accept r>
] with-destructors ;
: check-shutdown-response ( handle r -- event )
: check-shutdown-response ( handle r -- event ) USING: io prettyprint ;
#! SSL_shutdown always returns 0 due to openssl bugs?
{
{ 1 [ drop f ] }
{ 0 [
dup SSL_want {
{ SSL_NOTHING [ dup SSL_shutdown check-shutdown-response ] }
dup handle>> SSL_want
{
{ SSL_NOTHING [ dup handle>> SSL_shutdown check-shutdown-response ] }
{ SSL_READING [ drop +input+ ] }
{ SSL_WRITING [ drop +output+ ] }
} case
] }
{ -1 [
-1 SSL_get_error
handle>> -1 SSL_get_error
{
{ SSL_ERROR_WANT_READ [ +input+ ] }
{ SSL_ERROR_WANT_WRITE [ +output+ ] }
@ -143,6 +145,6 @@ M: ssl (accept)
M: unix ssl-shutdown
dup connected>> [
dup handle>> dup SSL_shutdown check-shutdown-response
dup dup handle>> SSL_shutdown check-shutdown-response
dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if
] [ drop ] if ;

107
extra/openssl/libssl/libssl.factor
View File

@ -5,7 +5,8 @@
!
! export LD_LIBRARY_PATH=/opt/local/lib
USING: alien alien.syntax combinators kernel system ;
USING: alien alien.syntax combinators kernel system namespaces
assocs parser sequences words quotations ;
IN: openssl.libssl
@ -176,6 +177,12 @@ FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ;
FUNCTION: void* BIO_f_ssl ( ) ;
: SSL_CTX_set_tmp_rsa ( ctx rsa -- n )
>r SSL_CTRL_SET_TMP_RSA 0 r> SSL_CTX_ctrl ;
: SSL_CTX_set_tmp_dh ( ctx dh -- n )
>r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ;
! ===============================================
! x509.h
! ===============================================
@ -191,47 +198,63 @@ FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ;
! x509_vfy.h
! ===============================================
: X509_V_OK 0 ; inline
: X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT 2 ; inline
: X509_V_ERR_UNABLE_TO_GET_CRL 3 ; inline
: X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE 4 ; inline
: X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE 5 ; inline
: X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY 6 ; inline
: X509_V_ERR_CERT_SIGNATURE_FAILURE 7 ; inline
: X509_V_ERR_CRL_SIGNATURE_FAILURE 8 ; inline
: X509_V_ERR_CERT_NOT_YET_VALID 9 ; inline
: X509_V_ERR_CERT_HAS_EXPIRED 10 ; inline
: X509_V_ERR_CRL_NOT_YET_VALID 11 ; inline
: X509_V_ERR_CRL_HAS_EXPIRED 12 ; inline
: X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD 13 ; inline
: X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD 14 ; inline
: X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD 15 ; inline
: X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD 16 ; inline
: X509_V_ERR_OUT_OF_MEM 17 ; inline
: X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT 18 ; inline
: X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN 19 ; inline
: X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY 20 ; inline
: X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE 21 ; inline
: X509_V_ERR_CERT_CHAIN_TOO_LONG 22 ; inline
: X509_V_ERR_CERT_REVOKED 23 ; inline
: X509_V_ERR_INVALID_CA 24 ; inline
: X509_V_ERR_PATH_LENGTH_EXCEEDED 25 ; inline
: X509_V_ERR_INVALID_PURPOSE 26 ; inline
: X509_V_ERR_CERT_UNTRUSTED 27 ; inline
: X509_V_ERR_CERT_REJECTED 28 ; inline
: X509_V_ERR_SUBJECT_ISSUER_MISMATCH 29 ; inline
: X509_V_ERR_AKID_SKID_MISMATCH 30 ; inline
: X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH 31 ; inline
: X509_V_ERR_KEYUSAGE_NO_CERTSIGN 32 ; inline
: X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER 33 ; inline
: X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION 34 ; inline
: X509_V_ERR_KEYUSAGE_NO_CRL_SIGN 35 ; inline
: X509_V_ERR_UNHANDLED_CRITICAL_CRL_EXTENSION 36 ; inline
: X509_V_ERR_INVALID_NON_CA 37 ; inline
: X509_V_ERR_PROXY_PATH_LENGTH_EXCEEDED 38 ; inline
: X509_V_ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE 39 ; inline
: X509_V_ERR_PROXY_CERTIFICATES_NOT_ALLOWED 40 ; inline
: X509_V_ERR_APPLICATION_VERIFICATION 50 ; inline
<<
SYMBOL: verify-messages
H{ } clone verify-messages set-global
: verify-message ( n -- word ) verify-messages get-global at ;
: X509_V_:
scan "X509_V_" prepend create-in
scan-word
[ 1quotation define-inline ]
[ verify-messages get set-at ] 2bi ; parsing
>>
X509_V_: OK 0
X509_V_: ERR_UNABLE_TO_GET_ISSUER_CERT 2
X509_V_: ERR_UNABLE_TO_GET_CRL 3
X509_V_: ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE 4
X509_V_: ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE 5
X509_V_: ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY 6
X509_V_: ERR_CERT_SIGNATURE_FAILURE 7
X509_V_: ERR_CRL_SIGNATURE_FAILURE 8
X509_V_: ERR_CERT_NOT_YET_VALID 9
X509_V_: ERR_CERT_HAS_EXPIRED 10
X509_V_: ERR_CRL_NOT_YET_VALID 11
X509_V_: ERR_CRL_HAS_EXPIRED 12
X509_V_: ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD 13
X509_V_: ERR_ERROR_IN_CERT_NOT_AFTER_FIELD 14
X509_V_: ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD 15
X509_V_: ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD 16
X509_V_: ERR_OUT_OF_MEM 17
X509_V_: ERR_DEPTH_ZERO_SELF_SIGNED_CERT 18
X509_V_: ERR_SELF_SIGNED_CERT_IN_CHAIN 19
X509_V_: ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY 20
X509_V_: ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE 21
X509_V_: ERR_CERT_CHAIN_TOO_LONG 22
X509_V_: ERR_CERT_REVOKED 23
X509_V_: ERR_INVALID_CA 24
X509_V_: ERR_PATH_LENGTH_EXCEEDED 25
X509_V_: ERR_INVALID_PURPOSE 26
X509_V_: ERR_CERT_UNTRUSTED 27
X509_V_: ERR_CERT_REJECTED 28
X509_V_: ERR_SUBJECT_ISSUER_MISMATCH 29
X509_V_: ERR_AKID_SKID_MISMATCH 30
X509_V_: ERR_AKID_ISSUER_SERIAL_MISMATCH 31
X509_V_: ERR_KEYUSAGE_NO_CERTSIGN 32
X509_V_: ERR_UNABLE_TO_GET_CRL_ISSUER 33
X509_V_: ERR_UNHANDLED_CRITICAL_EXTENSION 34
X509_V_: ERR_KEYUSAGE_NO_CRL_SIGN 35
X509_V_: ERR_UNHANDLED_CRITICAL_CRL_EXTENSION 36
X509_V_: ERR_INVALID_NON_CA 37
X509_V_: ERR_PROXY_PATH_LENGTH_EXCEEDED 38
X509_V_: ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE 39
X509_V_: ERR_PROXY_CERTIFICATES_NOT_ALLOWED 40
X509_V_: ERR_APPLICATION_VERIFICATION 50
! ===============================================
! obj_mac.h

1
extra/openssl/openssl-tests.factor
View File

@ -6,6 +6,7 @@ openssl ssl-backend [
<ssl-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" ascii string>alien >>password
[ ] with-ssl-context
] unit-test

58
extra/openssl/openssl.factor
View File

@ -47,7 +47,7 @@ SYMBOL: ssl-initiazed?
[ f ssl-initiazed? set-global ] "openssl" add-init-hook
TUPLE: openssl-context < ssl-context aliens ;
TUPLE: openssl-context < secure-context aliens ;
: load-certificate-chain ( ctx -- )
dup config>> key-file>> [
@ -99,25 +99,57 @@ TUPLE: openssl-context < ssl-context aliens ;
: set-verify-depth ( ctx -- )
handle>> 1 SSL_CTX_set_verify_depth ;
M: openssl <ssl-context> ( config -- context )
TUPLE: bio handle disposed ;
: <bio> f bio boa ;
M: bio dispose* handle>> BIO_free ssl-error ;
: <file-bio> ( path -- bio )
normalize-path "r" BIO_new_file dup ssl-error <bio> ;
: load-dh-params ( ctx -- )
dup config>> dh-file>> [
[ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
handle>> f f f PEM_read_bio_DHparams dup ssl-error
SSL_CTX_set_tmp_dh ssl-error
] [ drop ] if ;
TUPLE: rsa handle disposed ;
: <rsa> f rsa boa ;
M: rsa dispose* handle>> RSA_free ;
: generate-eph-rsa-key ( ctx -- )
[ handle>> ]
[
config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
dup ssl-error <rsa> &dispose handle>>
] bi
SSL_CTX_set_tmp_rsa ssl-error ;
M: openssl <secure-context> ( config -- context )
maybe-init-ssl
[
dup method>> ssl-method SSL_CTX_new
dup ssl-error V{ } clone openssl-context boa |dispose
dup ssl-error f V{ } clone openssl-context boa |dispose
{
[ load-certificate-chain ]
[ set-default-password ]
[ use-private-key-file ]
[ load-verify-locations ]
[ set-verify-depth ]
[ load-dh-params ]
[ generate-eph-rsa-key ]
[ ]
} cleave
] with-destructors ;
M: openssl-context dispose
dup aliens>> [ free ] each f >>aliens
dup handle>> [ SSL_CTX_free ] when* f >>handle
drop ;
M: openssl-context dispose*
[ aliens>> [ free ] each ]
[ handle>> SSL_CTX_free ]
bi ;
TUPLE: ssl-handle file handle connected disposed ;
@ -127,7 +159,7 @@ M: no-ssl-context summary
drop "SSL operations must be wrapped in calls to with-ssl-context" ;
: current-ssl-context ( -- ctx )
ssl-context get [ no-ssl-context ] unless* ;
secure-context get [ no-ssl-context ] unless* ;
: <ssl-handle> ( fd -- ssl )
current-ssl-context handle>> SSL_new dup ssl-error
@ -141,11 +173,9 @@ M: ssl-handle dispose*
[ file>> dispose ]
tri ;
ERROR: certificate-verify-error result ;
: check-verify-result ( ssl-handle -- )
SSL_get_verify_result dup X509_V_OK =
[ certificate-verify-error ] [ drop ] if ;
[ drop ] [ verify-message certificate-verify-error ] if ;
: common-name ( certificate -- host )
X509_get_subject_name
@ -153,16 +183,14 @@ ERROR: certificate-verify-error result ;
[ 256 X509_NAME_get_text_by_NID ] keep
swap -1 = [ drop f ] [ ascii alien>string ] if ;
ERROR: common-name-verify-error expected got ;
: check-common-name ( host ssl-handle -- )
SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ =
[ 2drop ] [ common-name-verify-error ] if ;
: check-certificate ( host ssl -- )
M: openssl check-certificate ( host ssl -- )
handle>>
[ nip check-verify-result ]
[ check-common-name ]
2bi ;
openssl ssl-backend set-global
openssl secure-socket-backend set-global

1
extra/unix/unix.factor
View File

@ -120,6 +120,7 @@ FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_
FUNCTION: int munmap ( void* addr, size_t len ) ;
FUNCTION: uint ntohl ( uint n ) ;
FUNCTION: ushort ntohs ( ushort n ) ;
FUNCTION: int shutdown ( int fd, int how ) ;
FUNCTION: int open ( char* path, int flags, int prot ) ;