From 1ecc54770e8ba0a777d87a239a7be48fdbcf452a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 17 May 2008 17:45:56 -0500
Subject: [PATCH] Fix SSL shutdown
---
extra/io/server/server.factor | 12 +-
extra/io/sockets/secure/secure-tests.factor | 6 +-
extra/io/sockets/secure/secure.factor | 60 +++++++---
extra/io/sockets/sockets.factor | 7 +-
.../unix/sockets/secure/secure-tests.factor | 90 +++++++++++++++
extra/io/unix/sockets/secure/secure.factor | 34 +++---
extra/openssl/libssl/libssl.factor | 107 +++++++++++-------
extra/openssl/openssl-tests.factor | 1 +
extra/openssl/openssl.factor | 58 +++++++---
extra/unix/unix.factor | 1 +
10 files changed, 274 insertions(+), 102 deletions(-)
create mode 100644 extra/io/unix/sockets/secure/secure-tests.factor
diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor
index 221a3301ce..359b9c6fb4 100755
--- a/extra/io/server/server.factor
+++ b/extra/io/server/server.factor
@@ -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
diff --git a/extra/io/sockets/secure/secure-tests.factor b/extra/io/sockets/secure/secure-tests.factor
index a2287c28f7..9b9436a8db 100644
--- a/extra/io/sockets/secure/secure-tests.factor
+++ b/extra/io/sockets/secure/secure-tests.factor
@@ -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
diff --git a/extra/io/sockets/secure/secure.factor b/extra/io/sockets/secure/secure.factor
index d9ca85ddd6..22265b9069 100644
--- a/extra/io/sockets/secure/secure.factor
+++ b/extra/io/sockets/secure/secure.factor
@@ -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" ;
diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor
index ae2b7872b9..93185f50f6 100755
--- a/extra/io/sockets/sockets.factor
+++ b/extra/io/sockets/sockets.factor
@@ -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 ;
diff --git a/extra/io/unix/sockets/secure/secure-tests.factor b/extra/io/unix/sockets/secure/secure-tests.factor
new file mode 100644
index 0000000000..9a6a87d8ed
--- /dev/null
+++ b/extra/io/unix/sockets/secure/secure-tests.factor
@@ -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
diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor
index b4381de43b..778fbebb1b 100644
--- a/extra/io/unix/sockets/secure/secure.factor
+++ b/extra/io/unix/sockets/secure/secure.factor
@@ -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 ;
diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor
index 42ccac2312..f5680972f3 100755
--- a/extra/openssl/libssl/libssl.factor
+++ b/extra/openssl/libssl/libssl.factor
@@ -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
diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor
index d06340d518..30c36c0315 100755
--- a/extra/openssl/openssl-tests.factor
+++ b/extra/openssl/openssl-tests.factor
@@ -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
diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor
index 695b9a1d7d..9bfec98b64 100755
--- a/extra/openssl/openssl.factor
+++ b/extra/openssl/openssl.factor
@@ -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
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index 9a7d405546..35f6a2f6cd 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -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 ) ;