New I/O timeout system

extra/http/client/client.factor

@@ -47,7 +47,7 @@ DEFER: http-get-stream
         dispose "location" swap peek-at nip http-get-stream
     ] when ;
 
-: default-timeout 60 1000 * over set-timeout ;
+: default-timeout 1 minutes over set-timeout ;
 
 : http-get-stream ( url -- code headers stream )
     #! Opens a stream for reading from an HTTP URL.

extra/http/server/server.factor

@@ -50,7 +50,7 @@ IN: http.server
 
 : httpd ( port -- )
     internet-server "http.server" [
-        60000 stdio get set-timeout
+        1 minutes stdio get set-timeout
         readln [ parse-request ] when*
     ] with-server ;
 

extra/io/launcher/launcher-docs.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax quotations kernel io math ;
+USING: help.markup help.syntax quotations kernel io math
+calendar ;
 IN: io.launcher
 
 HELP: +command+
@@ -77,7 +78,7 @@ $nl
 "This is used in situations where you want a spawn child process with some overridden environment variables." } ;
 
 HELP: +timeout+
-{ $description "Launch descriptor key. If set, specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
+{ $description "Launch descriptor key. If set to a " { $link dt } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
 
 HELP: default-descriptor
 { $description "Association storing default values for launch descriptor keys." } ;

extra/io/launcher/launcher.factor

@@ -10,14 +10,14 @@ SYMBOL: processes
 
 [ H{ } clone processes set-global ] "io.launcher" add-init-hook
 
-TUPLE: process handle status killed? lapse ;
+TUPLE: process handle status killed? timeout ;
 
 HOOK: register-process io-backend ( process -- )
 
 M: object register-process drop ;
 
 : <process> ( handle -- process )
-    f f <lapse> process construct-boa
+    f f f process construct-boa
     V{ } clone over processes get set-at
     dup register-process ;
 
@@ -115,7 +115,9 @@ HOOK: kill-process* io-backend ( handle -- )
     t over set-process-killed?
     process-handle [ kill-process* ] when* ;
 
-M: process get-lapse process-lapse ;
+M: process timeout process-timeout ;
+
+M: process set-timeout set-process-timeout ;
 
 M: process timed-out kill-process ;
 

extra/io/nonblocking/nonblocking.factor

@@ -13,11 +13,12 @@ SYMBOL: default-buffer-size
 TUPLE: port
 handle
 error
-lapse
+timeout
 type eof? ;
 
-! Ports support the lapse protocol
+M: port timeout port-timeout ;
-M: port get-lapse port-lapse ;
+
+M: port set-timeout set-port-timeout ;
 
 SYMBOL: closed
 
@@ -28,12 +29,10 @@ GENERIC: init-handle ( handle -- )
 GENERIC: close-handle ( handle -- )
 
 : <port> ( handle buffer type -- port )
-    pick init-handle
+    pick init-handle {
-    <lapse> {
         set-port-handle
         set-delegate
         set-port-type
-        set-port-lapse
     } port construct ;
 
 : <buffered-port> ( handle type -- port )

extra/io/timeouts/timeouts-docs.factor

@@ -1,14 +1,13 @@
 IN: io.timeouts
-USING: help.markup help.syntax math kernel ;
+USING: help.markup help.syntax math kernel calendar ;
 
-HELP: get-lapse
+HELP: timeout
-{ $values { "obj" object } { "lapse" lapse } }
+{ $values { "obj" object } { "dt/f" "a " { $link dt } " or " { $link f } } }
-{ $contract "Outputs an object's timeout lapse descriptor." } ;
+{ $contract "Outputs an object's timeout." } ;
 
 HELP: set-timeout
-{ $values { "ms" integer } { "obj" object } }
+{ $values { "dt/f" "a " { $link dt } " or " { $link f } } { "obj" object } }
-{ $contract "Sets an object's timeout, in milliseconds." }
+{ $contract "Sets an object's timeout." } ;
-{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ;
 
 HELP: timed-out
 { $values { "obj" object } }
@@ -20,9 +19,9 @@ HELP: with-timeout
 
 ARTICLE: "io.timeouts" "I/O timeout protocol"
 "Streams and processes 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 get-lapse }
 { $subsection timed-out }
 "A combinator to be used in operations which can time out:"
 { $subsection with-timeout }

extra/io/timeouts/timeouts.factor

@@ -1,79 +1,27 @@
 ! Copyright (C) 2008 Slava Pestov, Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math system dlists namespaces assocs init
+USING: kernel calendar alarms io.streams.duplex ;
-threads io.streams.duplex ;
 IN: io.timeouts
 
-TUPLE: lapse entry timeout cutoff ;
-
-: <lapse> f 0 0 \ lapse construct-boa ;
-
 ! Won't need this with new slot accessors
-GENERIC: get-lapse ( obj -- lapse )
+GENERIC: timeout ( obj -- dt/f )
+GENERIC: set-timeout ( dt/f obj -- )
 
-GENERIC: set-timeout ( ms obj -- )
+M: duplex-stream set-timeout
-
+    2dup
-M: object set-timeout get-lapse set-timeout ;
-
-M: lapse set-timeout set-lapse-timeout ;
-
-: timeout ( obj -- ms ) get-lapse lapse-timeout ;
-: entry ( obj -- dlist-node ) get-lapse lapse-entry ;
-: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ;
-: cutoff ( obj -- ms ) get-lapse lapse-cutoff ;
-: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;
-
-! Won't need this with inheritance
-TUPLE: duplex-stream-lapse stream ;
-
-M: duplex-stream-lapse set-timeout
-    duplex-stream-lapse-stream 2dup
     duplex-stream-in set-timeout
     duplex-stream-out set-timeout ;
 
-M: duplex-stream get-lapse duplex-stream-lapse construct-boa ;
-
-SYMBOL: timeout-queue
-
-: timeout? ( lapse -- ? )
-    cutoff dup zero? not swap millis < and ;
-
-timeout-queue global [ [ <dlist> ] unless* ] change-at
-
-: unqueue-timeout ( obj -- )
-    entry [
-        timeout-queue get-global swap delete-node
-    ] when* ;
-
-: queue-timeout ( obj -- )
-    dup timeout-queue get-global push-front*
-    swap set-entry ;
-
 GENERIC: timed-out ( obj -- )
 
 M: object timed-out drop ;
 
-: expire-timeouts ( -- )
+: queue-timeout ( obj timeout -- alarm )
-    timeout-queue get-global dup dlist-empty? [ drop ] [
+    from-now f rot [ timed-out ] curry add-alarm ;
-        dup peek-back timeout?
-        [ pop-back timed-out expire-timeouts ] [ drop ] if
-    ] if ;
-
-: begin-timeout ( obj -- )
-    dup timeout dup zero? [
-        2drop
-    ] [
-        millis + over set-cutoff
-        dup unqueue-timeout queue-timeout
-    ] if ;
 
 : with-timeout ( obj quot -- )
-    over begin-timeout keep unqueue-timeout ; inline
+    over dup timeout dup [
-
+        queue-timeout slip cancel-alarm
-: expiry-thread ( -- )
+    ] [
-    expire-timeouts 5000 sleep expiry-thread ;
+        2drop call
-
+    ] if ; inline
-: start-expiry-thread ( -- )
-    [ expiry-thread ] "I/O expiry" spawn drop ;
-
-[ start-expiry-thread ] "io.timeouts" add-init-hook

extra/io/windows/launcher/launcher.factor

@@ -146,10 +146,16 @@ M: windows-io kill-process* ( handle -- )
 
 : wait-loop ( -- )
     processes get dup assoc-empty?
-    [ drop t ] [ wait-for-processes ] if
+    [ drop f nap drop ]
-    [ 250 sleep ] when ;
+    [ wait-for-processes [ 100 nap drop ] when ] if ;
+
+SYMBOL: wait-thread
 
 : start-wait-thread ( -- )
-    [ wait-loop t ] "Process wait" spawn-server drop ;
+    [ wait-loop t ] "Process wait" spawn-server
+    wait-thread set-global ;
+
+M: windows-io register-process
+    drop wait-thread get-global interrupt ;
 
 [ start-wait-thread ] "io.windows.launcher" add-init-hook

extra/smtp/server/server.factor

@@ -66,7 +66,7 @@ SYMBOL: data-mode
     "Starting SMTP server on port " write dup . flush
     "127.0.0.1" swap <inet4> <server> [
         accept [
-            60000 stdio get set-timeout
+            1 minutes stdio get set-timeout
             "220 hello\r\n" write flush
             process
             global [ flush ] bind