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