SSL context is now implicit
parent
bf01d85e12
commit
f1c8f3c559
|
@ -115,7 +115,7 @@ M: output-port dispose*
|
||||||
[
|
[
|
||||||
[ handle>> &dispose drop ]
|
[ handle>> &dispose drop ]
|
||||||
[ port-flush ]
|
[ port-flush ]
|
||||||
[ [ handle>> shutdown ] with-timeout ]
|
[ handle>> shutdown ]
|
||||||
tri
|
tri
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
|
@ -129,12 +129,6 @@ M: port cancel-operation handle>> cancel-operation ;
|
||||||
M: port dispose*
|
M: port dispose*
|
||||||
[
|
[
|
||||||
[ handle>> &dispose drop ]
|
[ handle>> &dispose drop ]
|
||||||
[ [ handle>> shutdown ] with-timeout ]
|
[ handle>> shutdown ]
|
||||||
bi
|
bi
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
: <ports> ( read-handle write-handle -- input-port output-port )
|
|
||||||
[
|
|
||||||
[ <input-port> |dispose ]
|
|
||||||
[ <output-port> |dispose ] bi*
|
|
||||||
] with-destructors ;
|
|
||||||
|
|
|
@ -161,6 +161,11 @@ GENERIC: (get-remote-address) ( handle remote -- sockaddr )
|
||||||
: get-remote-address ( handle local -- remote )
|
: get-remote-address ( handle local -- remote )
|
||||||
[ (get-remote-address) ] keep parse-sockaddr ;
|
[ (get-remote-address) ] keep parse-sockaddr ;
|
||||||
|
|
||||||
|
: <ports> ( handle -- input-port output-port )
|
||||||
|
[
|
||||||
|
[ <input-port> |dispose ] [ <output-port> |dispose ] bi
|
||||||
|
] with-destructors ;
|
||||||
|
|
||||||
GENERIC: establish-connection ( client-out remote -- )
|
GENERIC: establish-connection ( client-out remote -- )
|
||||||
|
|
||||||
GENERIC: ((client)) ( remote -- handle )
|
GENERIC: ((client)) ( remote -- handle )
|
||||||
|
@ -173,7 +178,7 @@ M: object (client) ( remote -- client-in client-out local )
|
||||||
[
|
[
|
||||||
[ ((client)) ] keep
|
[ ((client)) ] keep
|
||||||
[
|
[
|
||||||
>r dup <ports> [ |dispose ] bi@ dup r>
|
>r <ports> [ |dispose ] bi@ dup r>
|
||||||
establish-connection
|
establish-connection
|
||||||
]
|
]
|
||||||
[ get-local-address ]
|
[ get-local-address ]
|
||||||
|
@ -210,7 +215,7 @@ GENERIC: (accept) ( server addrspec -- handle sockaddr )
|
||||||
dup addr>>
|
dup addr>>
|
||||||
[ (accept) ] keep
|
[ (accept) ] keep
|
||||||
parse-sockaddr swap
|
parse-sockaddr swap
|
||||||
dup <ports>
|
<ports>
|
||||||
] keep encoding>> <encoder-duplex> swap ;
|
] keep encoding>> <encoder-duplex> swap ;
|
||||||
|
|
||||||
TUPLE: datagram-port < port addr ;
|
TUPLE: datagram-port < port addr ;
|
||||||
|
|
|
@ -8,7 +8,6 @@ io.encodings.utf8 destructors accessors inspector combinators ;
|
||||||
QUALIFIED: io
|
QUALIFIED: io
|
||||||
IN: io.unix.backend
|
IN: io.unix.backend
|
||||||
|
|
||||||
! I/O tasks
|
|
||||||
GENERIC: handle-fd ( handle -- fd )
|
GENERIC: handle-fd ( handle -- fd )
|
||||||
|
|
||||||
TUPLE: fd fd disposed ;
|
TUPLE: fd fd disposed ;
|
||||||
|
@ -18,9 +17,11 @@ TUPLE: fd fd disposed ;
|
||||||
#! since on OS X 10.3, this operation fails from init-io
|
#! since on OS X 10.3, this operation fails from init-io
|
||||||
#! when running the Factor.app (presumably because fd 0 and
|
#! when running the Factor.app (presumably because fd 0 and
|
||||||
#! 1 are closed).
|
#! 1 are closed).
|
||||||
|
fd new
|
||||||
|
swap
|
||||||
[ F_SETFL O_NONBLOCK fcntl drop ]
|
[ F_SETFL O_NONBLOCK fcntl drop ]
|
||||||
[ F_SETFD FD_CLOEXEC fcntl drop ]
|
[ F_SETFD FD_CLOEXEC fcntl drop ]
|
||||||
[ f fd boa ]
|
[ >>fd ]
|
||||||
tri ;
|
tri ;
|
||||||
|
|
||||||
M: fd dispose*
|
M: fd dispose*
|
||||||
|
@ -99,15 +100,6 @@ M: io-timeout summary drop "I/O operation timed out" ;
|
||||||
! Some general stuff
|
! Some general stuff
|
||||||
: file-mode OCT: 0666 ;
|
: file-mode OCT: 0666 ;
|
||||||
|
|
||||||
: (io-error) ( -- * ) err_no strerror throw ;
|
|
||||||
|
|
||||||
: check-errno ( -- )
|
|
||||||
err_no dup zero? [ drop ] [ strerror throw ] if ;
|
|
||||||
|
|
||||||
: check-null ( n -- ) zero? [ (io-error) ] when ;
|
|
||||||
|
|
||||||
: io-error ( n -- ) 0 < [ (io-error) ] when ;
|
|
||||||
|
|
||||||
! Readers
|
! Readers
|
||||||
: (refill) ( port -- n )
|
: (refill) ( port -- n )
|
||||||
[ handle>> ]
|
[ handle>> ]
|
||||||
|
|
|
@ -118,10 +118,12 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
1 seconds secure-socket-timeout [
|
||||||
<secure-config> [
|
<secure-config> [
|
||||||
"127.0.0.1" "port" get ?promise <inet4> <secure>
|
"127.0.0.1" "port" get ?promise <inet4> <secure>
|
||||||
ascii <client> drop 1 seconds over set-timeout dispose
|
ascii <client> drop dispose
|
||||||
] with-secure-context
|
] with-secure-context
|
||||||
|
] with-variable
|
||||||
] [ io-timeout? ] must-fail-with
|
] [ io-timeout? ] must-fail-with
|
||||||
|
|
||||||
! Server socket shutdown timeout
|
! Server socket shutdown timeout
|
||||||
|
@ -137,10 +139,12 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
1 seconds secure-socket-timeout [
|
||||||
[
|
[
|
||||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||||
dup addr>> addrspec>> port>> "port" get fulfill
|
dup addr>> addrspec>> port>> "port" get fulfill
|
||||||
accept drop 1 seconds over set-timeout dispose
|
accept drop dispose
|
||||||
] with-disposal
|
] with-disposal
|
||||||
] with-test-context
|
] with-test-context
|
||||||
|
] with-variable
|
||||||
] [ io-timeout? ] must-fail-with
|
] [ io-timeout? ] must-fail-with
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors byte-arrays kernel debugger sequences namespaces math
|
USING: accessors unix byte-arrays kernel debugger sequences namespaces math
|
||||||
math.order combinators init alien alien.c-types alien.strings libc
|
math.order combinators init alien alien.c-types alien.strings libc
|
||||||
continuations destructors
|
continuations destructors
|
||||||
openssl openssl.libcrypto openssl.libssl
|
openssl openssl.libcrypto openssl.libssl
|
||||||
|
@ -15,7 +15,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
|
||||||
ERR_get_error dup zero? [
|
ERR_get_error dup zero? [
|
||||||
drop
|
drop
|
||||||
{
|
{
|
||||||
{ -1 [ (io-error) ] }
|
{ -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
|
||||||
{ 0 [ premature-close ] }
|
{ 0 [ premature-close ] }
|
||||||
} case
|
} case
|
||||||
] [
|
] [
|
||||||
|
@ -157,5 +157,7 @@ M: secure (accept)
|
||||||
dup dup handle>> SSL_shutdown check-shutdown-response
|
dup dup handle>> SSL_shutdown check-shutdown-response
|
||||||
dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ;
|
dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ;
|
||||||
|
|
||||||
M: ssl-handle shutdown USE: io.streams.c
|
M: ssl-handle shutdown
|
||||||
dup connected>> [ f >>connected (shutdown) ] [ drop ] if ;
|
dup connected>> [
|
||||||
|
f >>connected [ (shutdown) ] with-timeout
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
|
@ -159,11 +159,22 @@ ERROR: no-secure-context ;
|
||||||
M: no-secure-context summary
|
M: no-secure-context summary
|
||||||
drop "Secure socket operations must be wrapped in calls to with-secure-context" ;
|
drop "Secure socket operations must be wrapped in calls to with-secure-context" ;
|
||||||
|
|
||||||
: current-ssl-context ( -- ctx )
|
SYMBOL: default-secure-context
|
||||||
secure-context get [ no-secure-context ] unless* ;
|
|
||||||
|
: context-expired? ( context -- ? )
|
||||||
|
dup [ handle>> expired? ] [ drop t ] if ;
|
||||||
|
|
||||||
|
: current-secure-context ( -- ctx )
|
||||||
|
secure-context get [
|
||||||
|
default-secure-context get dup context-expired? [
|
||||||
|
drop
|
||||||
|
<secure-config> <secure-context> default-secure-context set-global
|
||||||
|
current-secure-context
|
||||||
|
] when
|
||||||
|
] unless* ;
|
||||||
|
|
||||||
: <ssl-handle> ( fd -- ssl )
|
: <ssl-handle> ( fd -- ssl )
|
||||||
current-ssl-context handle>> SSL_new dup ssl-error
|
current-secure-context handle>> SSL_new dup ssl-error
|
||||||
f f ssl-handle boa ;
|
f f ssl-handle boa ;
|
||||||
|
|
||||||
M: ssl-handle dispose*
|
M: ssl-handle dispose*
|
||||||
|
|
Loading…
Reference in New Issue