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

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

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

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

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

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

@ -1,38 +1,68 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations USING: accessors kernel symbols namespaces continuations
destructors io.sockets sequences ; destructors io.sockets sequences inspector ;
IN: io.sockets.secure IN: io.sockets.secure
SYMBOL: ssl-backend SYMBOL: secure-socket-backend
SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ; 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 ) : <secure-config> ( -- config )
ssl-config new secure-config new
SSLv23 >>method ; 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-disposal
] with-scope ; inline ] 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 <PRIVATE
PREDICATE: ssl-inet < ssl addrspec>> inet? ; PREDICATE: secure-inet < secure addrspec>> inet? ;
M: ssl-inet (client) M: secure-inet (client)
addrspec>> resolve-client-addr [ <ssl> ] map (client) ; [
addrspec>>
[ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep
host>> pick handle>> check-certificate
] with-destructors ;
PRIVATE> 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 ) HOOK: (datagram) io-backend ( addr -- datagram )
: <datagram> ( addr -- datagram ) : <datagram> ( addrspec -- datagram )
[ [
[ (datagram) |dispose ] keep [ (datagram) |dispose ] keep
[ drop datagram-port <port> ] [ get-local-address ] 2bi [ drop datagram-port <port> ] [ get-local-address ] 2bi
@ -287,11 +287,8 @@ TUPLE: inet host port ;
C: <inet> inet C: <inet> inet
: resolve-client-addr ( inet -- seq )
[ host>> ] [ port>> ] bi f resolve-host ;
M: inet (client) M: inet (client)
resolve-client-addr (client) ; [ host>> ] [ port>> ] bi f resolve-host (client) ;
ERROR: invalid-inet-server addrspec ; 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 openssl openssl.libcrypto openssl.libssl
io.files io.ports io.unix.backend io.unix.sockets io.files io.ports io.unix.backend io.unix.sockets
io.encodings.ascii io.buffers io.sockets io.sockets.secure io.encodings.ascii io.buffers io.sockets io.sockets.secure
unix system ; unix system inspector ;
IN: io.unix.sockets.secure IN: io.unix.sockets.secure
M: ssl-handle handle-fd file>> handle-fd ; M: ssl-handle handle-fd file>> handle-fd ;
@ -16,7 +16,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
drop drop
{ {
{ -1 [ (io-error) ] } { -1 [ (io-error) ] }
{ 0 [ "Premature EOF" throw ] } { 0 [ premature-close ] }
} case } case
] [ ] [
nip (ssl-error) nip (ssl-error)
@ -26,7 +26,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
over handle>> handle>> over SSL_get_error ; inline over handle>> handle>> over SSL_get_error ; inline
! Input ports ! Input ports
: check-read-response ( port r -- event ) : check-read-response ( port r -- event ) USING: namespaces io prettyprint ;
check-response check-response
{ {
{ SSL_ERROR_NONE [ swap buffer>> n>buffer f ] } { 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> [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
[ handle>> swap dup SSL_set_bio ] keep ; [ handle>> swap dup SSL_set_bio ] keep ;
M: ssl ((client)) ( addrspec -- handle ) M: secure ((client)) ( addrspec -- handle )
addrspec>> ((client)) <ssl-socket> ; 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-connect-response ( port r -- event )
check-response check-response
@ -91,13 +91,13 @@ M: ssl (get-local-address) addrspec>> (get-local-address) ;
check-connect-response dup check-connect-response dup
[ dupd wait-for-port do-ssl-connect ] [ 2drop ] if ; [ 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 ] [ addrspec>> establish-connection ]
[ drop do-ssl-connect ] [ drop do-ssl-connect ]
[ drop handle>> t >>connected drop ] [ drop handle>> t >>connected drop ]
2tri ; 2tri ;
M: ssl (server) addrspec>> (server) ; M: secure (server) addrspec>> (server) ;
: check-accept-response ( handle r -- event ) : check-accept-response ( handle r -- event )
over handle>> over SSL_get_error over handle>> over SSL_get_error
@ -113,25 +113,27 @@ M: ssl (server) addrspec>> (server) ;
dup dup handle>> SSL_accept check-accept-response dup dup dup handle>> SSL_accept check-accept-response dup
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ; [ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
M: ssl (accept) M: secure (accept)
[ [
addrspec>> (accept) |dispose <ssl-socket> |dispose addrspec>> (accept) >r
dup do-ssl-accept |dispose <ssl-socket> t >>connected |dispose
dup do-ssl-accept r>
] with-destructors ; ] 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? #! SSL_shutdown always returns 0 due to openssl bugs?
{ {
{ 1 [ drop f ] } { 1 [ drop f ] }
{ 0 [ { 0 [
dup SSL_want { dup handle>> SSL_want
{ SSL_NOTHING [ dup SSL_shutdown check-shutdown-response ] } {
{ SSL_NOTHING [ dup handle>> SSL_shutdown check-shutdown-response ] }
{ SSL_READING [ drop +input+ ] } { SSL_READING [ drop +input+ ] }
{ SSL_WRITING [ drop +output+ ] } { SSL_WRITING [ drop +output+ ] }
} case } case
] } ] }
{ -1 [ { -1 [
-1 SSL_get_error handle>> -1 SSL_get_error
{ {
{ SSL_ERROR_WANT_READ [ +input+ ] } { SSL_ERROR_WANT_READ [ +input+ ] }
{ SSL_ERROR_WANT_WRITE [ +output+ ] } { SSL_ERROR_WANT_WRITE [ +output+ ] }
@ -143,6 +145,6 @@ M: ssl (accept)
M: unix ssl-shutdown M: unix ssl-shutdown
dup connected>> [ 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 dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if
] [ drop ] if ; ] [ drop ] if ;

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

@ -5,7 +5,8 @@
! !
! export LD_LIBRARY_PATH=/opt/local/lib ! 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 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 ( ) ; 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 ! x509.h
! =============================================== ! ===============================================
@ -191,47 +198,63 @@ FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ;
! x509_vfy.h ! 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 SYMBOL: verify-messages
: X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE 4 ; inline
: X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE 5 ; inline H{ } clone verify-messages set-global
: X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY 6 ; inline
: X509_V_ERR_CERT_SIGNATURE_FAILURE 7 ; inline : verify-message ( n -- word ) verify-messages get-global at ;
: X509_V_ERR_CRL_SIGNATURE_FAILURE 8 ; inline
: X509_V_ERR_CERT_NOT_YET_VALID 9 ; inline : X509_V_:
: X509_V_ERR_CERT_HAS_EXPIRED 10 ; inline scan "X509_V_" prepend create-in
: X509_V_ERR_CRL_NOT_YET_VALID 11 ; inline scan-word
: X509_V_ERR_CRL_HAS_EXPIRED 12 ; inline [ 1quotation define-inline ]
: X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD 13 ; inline [ verify-messages get set-at ] 2bi ; parsing
: 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_: OK 0
: X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT 18 ; inline X509_V_: ERR_UNABLE_TO_GET_ISSUER_CERT 2
: X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN 19 ; inline X509_V_: ERR_UNABLE_TO_GET_CRL 3
: X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY 20 ; inline X509_V_: ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE 4
: X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE 21 ; inline X509_V_: ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE 5
: X509_V_ERR_CERT_CHAIN_TOO_LONG 22 ; inline X509_V_: ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY 6
: X509_V_ERR_CERT_REVOKED 23 ; inline X509_V_: ERR_CERT_SIGNATURE_FAILURE 7
: X509_V_ERR_INVALID_CA 24 ; inline X509_V_: ERR_CRL_SIGNATURE_FAILURE 8
: X509_V_ERR_PATH_LENGTH_EXCEEDED 25 ; inline X509_V_: ERR_CERT_NOT_YET_VALID 9
: X509_V_ERR_INVALID_PURPOSE 26 ; inline X509_V_: ERR_CERT_HAS_EXPIRED 10
: X509_V_ERR_CERT_UNTRUSTED 27 ; inline X509_V_: ERR_CRL_NOT_YET_VALID 11
: X509_V_ERR_CERT_REJECTED 28 ; inline X509_V_: ERR_CRL_HAS_EXPIRED 12
: X509_V_ERR_SUBJECT_ISSUER_MISMATCH 29 ; inline X509_V_: ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD 13
: X509_V_ERR_AKID_SKID_MISMATCH 30 ; inline X509_V_: ERR_ERROR_IN_CERT_NOT_AFTER_FIELD 14
: X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH 31 ; inline X509_V_: ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD 15
: X509_V_ERR_KEYUSAGE_NO_CERTSIGN 32 ; inline X509_V_: ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD 16
: X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER 33 ; inline X509_V_: ERR_OUT_OF_MEM 17
: X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION 34 ; inline X509_V_: ERR_DEPTH_ZERO_SELF_SIGNED_CERT 18
: X509_V_ERR_KEYUSAGE_NO_CRL_SIGN 35 ; inline X509_V_: ERR_SELF_SIGNED_CERT_IN_CHAIN 19
: X509_V_ERR_UNHANDLED_CRITICAL_CRL_EXTENSION 36 ; inline X509_V_: ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY 20
: X509_V_ERR_INVALID_NON_CA 37 ; inline X509_V_: ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE 21
: X509_V_ERR_PROXY_PATH_LENGTH_EXCEEDED 38 ; inline X509_V_: ERR_CERT_CHAIN_TOO_LONG 22
: X509_V_ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE 39 ; inline X509_V_: ERR_CERT_REVOKED 23
: X509_V_ERR_PROXY_CERTIFICATES_NOT_ALLOWED 40 ; inline X509_V_: ERR_INVALID_CA 24
: X509_V_ERR_APPLICATION_VERIFICATION 50 ; inline 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 ! obj_mac.h

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

@ -6,6 +6,7 @@ openssl ssl-backend [
<ssl-config> <ssl-config>
"resource:extra/openssl/test/server.pem" >>key-file "resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file "resource:extra/openssl/test/root.pem" >>ca-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" ascii string>alien >>password "password" ascii string>alien >>password
[ ] with-ssl-context [ ] with-ssl-context
] unit-test ] 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 [ 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 -- ) : load-certificate-chain ( ctx -- )
dup config>> key-file>> [ dup config>> key-file>> [
@ -99,25 +99,57 @@ TUPLE: openssl-context < ssl-context aliens ;
: set-verify-depth ( ctx -- ) : set-verify-depth ( ctx -- )
handle>> 1 SSL_CTX_set_verify_depth ; 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 maybe-init-ssl
[ [
dup method>> ssl-method SSL_CTX_new 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 ] [ load-certificate-chain ]
[ set-default-password ] [ set-default-password ]
[ use-private-key-file ] [ use-private-key-file ]
[ load-verify-locations ] [ load-verify-locations ]
[ set-verify-depth ] [ set-verify-depth ]
[ load-dh-params ]
[ generate-eph-rsa-key ]
[ ] [ ]
} cleave } cleave
] with-destructors ; ] with-destructors ;
M: openssl-context dispose M: openssl-context dispose*
dup aliens>> [ free ] each f >>aliens [ aliens>> [ free ] each ]
dup handle>> [ SSL_CTX_free ] when* f >>handle [ handle>> SSL_CTX_free ]
drop ; bi ;
TUPLE: ssl-handle file handle connected disposed ; 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" ; drop "SSL operations must be wrapped in calls to with-ssl-context" ;
: current-ssl-context ( -- ctx ) : current-ssl-context ( -- ctx )
ssl-context get [ no-ssl-context ] unless* ; secure-context get [ no-ssl-context ] unless* ;
: <ssl-handle> ( fd -- ssl ) : <ssl-handle> ( fd -- ssl )
current-ssl-context handle>> SSL_new dup ssl-error current-ssl-context handle>> SSL_new dup ssl-error
@ -141,11 +173,9 @@ M: ssl-handle dispose*
[ file>> dispose ] [ file>> dispose ]
tri ; tri ;
ERROR: certificate-verify-error result ;
: check-verify-result ( ssl-handle -- ) : check-verify-result ( ssl-handle -- )
SSL_get_verify_result dup X509_V_OK = SSL_get_verify_result dup X509_V_OK =
[ certificate-verify-error ] [ drop ] if ; [ drop ] [ verify-message certificate-verify-error ] if ;
: common-name ( certificate -- host ) : common-name ( certificate -- host )
X509_get_subject_name X509_get_subject_name
@ -153,16 +183,14 @@ ERROR: certificate-verify-error result ;
[ 256 X509_NAME_get_text_by_NID ] keep [ 256 X509_NAME_get_text_by_NID ] keep
swap -1 = [ drop f ] [ ascii alien>string ] if ; swap -1 = [ drop f ] [ ascii alien>string ] if ;
ERROR: common-name-verify-error expected got ;
: check-common-name ( host ssl-handle -- ) : check-common-name ( host ssl-handle -- )
SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ = SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ =
[ 2drop ] [ common-name-verify-error ] if ; [ 2drop ] [ common-name-verify-error ] if ;
: check-certificate ( host ssl -- ) M: openssl check-certificate ( host ssl -- )
handle>> handle>>
[ nip check-verify-result ] [ nip check-verify-result ]
[ check-common-name ] [ check-common-name ]
2bi ; 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: int munmap ( void* addr, size_t len ) ;
FUNCTION: uint ntohl ( uint n ) ; FUNCTION: uint ntohl ( uint n ) ;
FUNCTION: ushort ntohs ( ushort n ) ; FUNCTION: ushort ntohs ( ushort n ) ;
FUNCTION: int shutdown ( int fd, int how ) ;
FUNCTION: int open ( char* path, int flags, int prot ) ; FUNCTION: int open ( char* path, int flags, int prot ) ;