Fix SSL timeout support and clean up some timeout code

db4
Slava Pestov 2008-05-21 01:36:30 -05:00
parent eec403d281
commit 70e89b5166
11 changed files with 156 additions and 61 deletions

View File

@ -147,7 +147,7 @@ M: process timeout timeout>> ;
M: process set-timeout set-process-timeout ;
M: process timed-out kill-process ;
M: process cancel-operation kill-process ;
M: object run-pipeline-element
[ >process swap >>stdout swap >>stdin run-detached ]

View File

@ -100,6 +100,10 @@ M: output-port stream-write
HOOK: (wait-to-write) io-backend ( port -- )
GENERIC: shutdown ( handle -- )
M: object shutdown drop ;
: port-flush ( port -- )
dup buffer>> buffer-empty?
[ drop ] [ dup (wait-to-write) port-flush ] if ;
@ -109,7 +113,10 @@ M: output-port stream-flush ( port -- )
M: output-port dispose*
[
[ handle>> &dispose drop ] [ port-flush ] bi
[ handle>> &dispose drop ]
[ port-flush ]
[ [ handle>> shutdown ] with-timeout ]
tri
] with-destructors ;
M: buffered-port dispose*
@ -117,11 +124,14 @@ M: buffered-port dispose*
[ [ [ buffer-free ] when* f ] change-buffer drop ]
bi ;
GENERIC: cancel-io ( handle -- )
M: port cancel-operation handle>> cancel-operation ;
M: port timed-out handle>> cancel-io ;
M: port dispose* handle>> dispose ;
M: port dispose*
[
[ handle>> &dispose drop ]
[ [ handle>> shutdown ] with-timeout ]
bi
] with-destructors ;
: <ports> ( read-handle write-handle -- input-port output-port )
[

View File

@ -1,9 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations
destructors io.sockets sequences inspector ;
destructors io.sockets sequences inspector calendar ;
IN: io.sockets.secure
SYMBOL: secure-socket-timeout
1 minutes secure-socket-timeout set-global
SYMBOL: secure-socket-backend
SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;

View File

@ -9,20 +9,20 @@ HELP: set-timeout
{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } }
{ $contract "Sets an object's timeout." } ;
HELP: timed-out
HELP: cancel-operation
{ $values { "obj" object } }
{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ;
HELP: with-timeout
{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link cancel-operation } " is called on the object." } ;
ARTICLE: "io.timeouts" "I/O timeout protocol"
"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
{ $subsection timeout }
{ $subsection set-timeout }
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
{ $subsection timed-out }
{ $subsection cancel-operation }
"A combinator to be used in operations which can time out:"
{ $subsection with-timeout }
{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ;

View File

@ -11,17 +11,18 @@ M: decoder set-timeout stream>> set-timeout ;
M: encoder set-timeout stream>> set-timeout ;
GENERIC: timed-out ( obj -- )
GENERIC: cancel-operation ( obj -- )
: queue-timeout ( obj timeout -- alarm )
>r [ timed-out ] curry r> later ;
>r [ cancel-operation ] curry r> later ;
: with-timeout* ( obj timeout quot -- )
3dup drop queue-timeout >r nip call r> cancel-alarm ;
inline
: with-timeout ( obj quot -- )
over dup timeout dup [
queue-timeout slip cancel-alarm
] [
2drop call
] if ; inline
over timeout [ >r dup timeout r> with-timeout* ] [ call ] if ;
inline
: timeouts ( dt -- )
[ input-stream get set-timeout ]

View File

@ -24,7 +24,7 @@ TUPLE: fd fd disposed ;
tri ;
M: fd dispose*
[ cancel-io ] [ fd>> close-file ] bi ;
[ cancel-operation ] [ fd>> close-file ] bi ;
M: fd handle-fd dup check-disposed fd>> ;
@ -63,7 +63,7 @@ GENERIC: wait-for-events ( ms mx -- )
: output-available ( fd mx -- )
remove-output-callbacks [ resume ] each ;
M: fd cancel-io ( fd -- )
M: fd cancel-operation ( fd -- )
dup disposed>> [ drop ] [
fd>>
mx get-global
@ -76,8 +76,12 @@ SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
SYMBOL: +output+
: wait-for-fd ( handle event -- timeout? )
dup +retry+ eq? [ 2drop f ] [
ERROR: io-timeout ;
M: io-timeout summary drop "I/O operation timed out" ;
: wait-for-fd ( handle event -- )
dup +retry+ eq? [ 2drop ] [
[
>r
swap handle-fd
@ -86,18 +90,11 @@ SYMBOL: +output+
{ +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] }
} case
] curry "I/O" suspend nip
] curry "I/O" suspend nip [ io-timeout ] when
] if ;
ERROR: io-timeout ;
M: io-timeout summary drop "I/O operation timed out" ;
: wait-for-port ( port event -- )
[
>r handle>> r> wait-for-fd
[ io-timeout ] when
] curry with-timeout ;
[ >r handle>> r> wait-for-fd ] curry with-timeout ;
! Some general stuff
: file-mode OCT: 0666 ;

View File

@ -1,8 +1,8 @@
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 locals ;
io.unix.backend classes words destructors threads tools.test
concurrency.promises byte-arrays locals calendar io.timeouts ;
\ <secure-config> must-infer
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
@ -63,3 +63,84 @@ concurrency.promises byte-arrays locals ;
<client> drop dispose
] with-secure-context
] [ certificate-verify-error? ] must-fail-with
! Client-side handshake timeout
[ ] [ <promise> "port" set ] unit-test
[ ] [
[
"127.0.0.1" 0 <inet4> ascii <server> [
dup addr>> port>> "port" get fulfill
accept drop 1 minutes sleep dispose
] with-disposal
] "Silly server" spawn drop
] unit-test
[
1 seconds secure-socket-timeout [
client-test
] with-variable
] [ io-timeout? ] must-fail-with
! Server-side handshake timeout
[ ] [ <promise> "port" set ] unit-test
[ ] [
[
"127.0.0.1" "port" get ?promise
<inet4> ascii <client> drop 1 minutes sleep dispose
] "Silly client" spawn drop
] unit-test
[
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
! Client socket shutdown timeout
[ ] [ <promise> "port" set ] unit-test
[ ] [
[
[
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
dup addr>> addrspec>> port>> "port" get fulfill
accept drop 1 minutes sleep dispose
] with-disposal
] with-test-context
] "Silly server" spawn drop
] 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
] [ io-timeout? ] must-fail-with
! Server socket shutdown timeout
[ ] [ <promise> "port" set ] unit-test
[ ] [
[
[
"127.0.0.1" "port" get ?promise
<inet4> <secure> ascii <client> drop 1 minutes sleep dispose
] with-test-context
] "Silly client" spawn drop
] 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
] [ io-timeout? ] must-fail-with

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 inspector ;
io.timeouts system inspector ;
IN: io.unix.sockets.secure
M: ssl-handle handle-fd file>> handle-fd ;
@ -64,8 +64,11 @@ M: ssl-handle drain
SSL_write
check-write-response ;
M: ssl-handle cancel-io
file>> cancel-io ;
M: ssl-handle cancel-operation
file>> cancel-operation ;
M: ssl-handle timeout
drop secure-socket-timeout get ;
! Client sockets
: <ssl-socket> ( fd -- ssl )
@ -79,8 +82,8 @@ M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
M: secure (get-local-address) addrspec>> (get-local-address) ;
: check-connect-response ( port r -- event )
check-response
: check-connect-response ( ssl-handle r -- event )
over handle>> over SSL_get_error
{
{ SSL_ERROR_NONE [ 2drop f ] }
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
@ -89,16 +92,18 @@ M: secure (get-local-address) addrspec>> (get-local-address) ;
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case ;
: do-ssl-connect ( port -- )
dup dup handle>> handle>> SSL_connect
check-connect-response dup
[ dupd wait-for-port do-ssl-connect ] [ 2drop ] if ;
: do-ssl-connect ( ssl-handle -- )
dup dup handle>> SSL_connect check-connect-response dup
[ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ;
M: secure establish-connection ( client-out remote -- )
[ addrspec>> establish-connection ]
[ drop do-ssl-connect ]
[ drop handle>> t >>connected drop ]
2tri ;
[
drop handle>>
[ [ do-ssl-connect ] with-timeout ]
[ t >>connected drop ]
bi
] 2bi ;
M: secure (server) addrspec>> (server) ;
@ -114,13 +119,13 @@ M: secure (server) addrspec>> (server) ;
: do-ssl-accept ( ssl-handle -- )
dup dup handle>> SSL_accept check-accept-response dup
[ >r dup file>> r> wait-for-fd drop do-ssl-accept ] [ 2drop ] if ;
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
M: secure (accept)
[
addrspec>> (accept) >r
|dispose <ssl-socket> t >>connected |dispose
dup do-ssl-accept r>
dup [ do-ssl-accept ] with-timeout r>
] with-destructors ;
: check-shutdown-response ( handle r -- event )
@ -130,7 +135,7 @@ M: secure (accept)
{ 0 [
dup handle>> dup f 0 SSL_read 2dup SSL_get_error
{
{ SSL_ERROR_ZERO_RETURN [ 2drop dup handle>> SSL_shutdown check-shutdown-response ] }
{ SSL_ERROR_ZERO_RETURN [ 3drop +retry+ ] }
{ SSL_ERROR_WANT_READ [ 3drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ 3drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error ] }
@ -148,8 +153,9 @@ M: secure (accept)
] }
} case ;
M: unix ssl-shutdown
dup connected>> [
dup dup handle>> SSL_shutdown check-shutdown-response
dup [ dupd wait-for-fd drop ssl-shutdown ] [ 2drop ] if
] [ drop ] if ;
: (shutdown) ( handle -- )
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 ;

View File

@ -71,7 +71,7 @@ M: winnt add-completion ( win32-handle -- )
resume-callback t
] if ;
M: win32-handle cancel-io
M: win32-handle cancel-operation
handle>> CancelIo drop ;
M: winnt io-multiplex ( ms -- )

View File

@ -25,7 +25,7 @@ TUPLE: win32-file < win32-handle ptr ;
win32-file new-win32-handle ;
M: win32-file dispose*
[ cancel-io ] [ call-next-method ] bi ;
[ cancel-operation ] [ call-next-method ] bi ;
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )

View File

@ -5,7 +5,8 @@ math.order combinators init alien alien.c-types alien.strings libc
continuations destructors debugger inspector
locals unicode.case
openssl.libcrypto openssl.libssl
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure ;
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
io.timeouts ;
IN: openssl
! This code is based on http://www.rtfm.com/openssl-examples/
@ -165,13 +166,8 @@ M: no-secure-context summary
current-ssl-context handle>> SSL_new dup ssl-error
f f ssl-handle boa ;
HOOK: ssl-shutdown io-backend ( handle -- )
M: ssl-handle dispose*
[ ssl-shutdown ]
[ handle>> SSL_free ]
[ file>> dispose ]
tri ;
[ handle>> SSL_free ] [ file>> dispose ] bi ;
: check-verify-result ( ssl-handle -- )
SSL_get_verify_result dup X509_V_OK =