Fix SSL timeout support and clean up some timeout code

extra/io/launcher/launcher.factor

@@ -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 ]

extra/io/ports/ports.factor

@@ -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*
-
+    [
-M: port dispose* handle>> dispose ;
+        [ handle>> &dispose drop ]
+        [ [ handle>> shutdown ] with-timeout ]
+        bi
+    ] with-destructors ;
 
 : <ports> ( read-handle write-handle -- input-port output-port )
     [

extra/io/sockets/secure/secure.factor

@@ -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 ;

extra/io/timeouts/timeouts-docs.factor

@@ -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" } ;

extra/io/timeouts/timeouts.factor

@@ -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 [
+    over timeout [ >r dup timeout r> with-timeout* ] [ call ] if ;
-        queue-timeout slip cancel-alarm
+    inline
-    ] [
-        2drop call
-    ] if ; inline
 
 : timeouts ( dt -- )
     [ input-stream get set-timeout ]

extra/io/unix/backend/backend.factor

@@ -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? )
+ERROR: io-timeout ;
-    dup +retry+ eq? [ 2drop f ] [
+
+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 ] curry with-timeout ;
-        >r handle>> r> wait-for-fd
-        [ io-timeout ] when
-    ] curry with-timeout ;
 
 ! Some general stuff
 : file-mode OCT: 0666 ;

extra/io/unix/sockets/secure/secure-tests.factor

@@ -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
+io.unix.backend classes words destructors threads tools.test
-concurrency.promises byte-arrays locals ;
+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

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 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
+M: ssl-handle cancel-operation
-    file>> cancel-io ;
+    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-connect-response ( ssl-handle r -- event )
-    check-response
+    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 -- )
+: do-ssl-connect ( ssl-handle -- )
-    dup dup handle>> handle>> SSL_connect
+    dup dup handle>> SSL_connect check-connect-response dup
-    check-connect-response dup
+    [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ;
-    [ dupd wait-for-port do-ssl-connect ] [ 2drop ] if ;
 
 M: secure establish-connection ( client-out remote -- )
     [ addrspec>> establish-connection ]
-    [ drop do-ssl-connect ]
+    [
-    [ drop handle>> t >>connected drop ]
+        drop handle>>
-    2tri ;
+        [ [ 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
+: (shutdown) ( handle -- )
-    dup connected>> [
+    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 drop ssl-shutdown ] [ 2drop ] if
+
-    ] [ drop ] if ;
+M: ssl-handle shutdown USE: io.streams.c
+    dup connected>> [ f >>connected (shutdown) ] [ drop ] if ;

extra/io/windows/nt/backend/backend.factor

@@ -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 -- )

extra/io/windows/windows.factor

@@ -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 )

extra/openssl/openssl.factor

@@ -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 ] bi ;
-    [ handle>> SSL_free ]
-    [ file>> dispose ]
-    tri ;
 
 : check-verify-result ( ssl-handle -- )
     SSL_get_verify_result dup X509_V_OK =