diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 679d603708..7945950acb 100755 --- a/extra/http/client/client.factor +++ b/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. diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 957a82d09f..112bfc3673 100755 --- a/extra/http/server/server.factor +++ b/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 ; diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 3a557e9fd5..48b2a01b7d 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/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." } ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index eda4332473..021ea487fc 100755 --- a/extra/io/launcher/launcher.factor +++ b/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 ; : ( handle -- process ) - f f 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 ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 72507f26b6..6798f37887 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/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 get-lapse port-lapse ; +M: port timeout port-timeout ; + +M: port set-timeout set-port-timeout ; SYMBOL: closed @@ -28,12 +29,10 @@ GENERIC: init-handle ( handle -- ) GENERIC: close-handle ( handle -- ) : ( handle buffer type -- port ) - pick init-handle - { + pick init-handle { set-port-handle set-delegate set-port-type - set-port-lapse } port construct ; : ( handle type -- port ) diff --git a/extra/io/timeouts/timeouts-docs.factor b/extra/io/timeouts/timeouts-docs.factor index a704e3473a..c03520bb56 100755 --- a/extra/io/timeouts/timeouts-docs.factor +++ b/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 -{ $values { "obj" object } { "lapse" lapse } } -{ $contract "Outputs an object's timeout lapse descriptor." } ; +HELP: timeout +{ $values { "obj" object } { "dt/f" "a " { $link dt } " or " { $link f } } } +{ $contract "Outputs an object's timeout." } ; HELP: set-timeout -{ $values { "ms" integer } { "obj" object } } -{ $contract "Sets an object's timeout, in milliseconds." } -{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ; +{ $values { "dt/f" "a " { $link dt } " or " { $link f } } { "obj" object } } +{ $contract "Sets an object's timeout." } ; 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 } diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index 0bae855399..966383ae23 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/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 -threads io.streams.duplex ; +USING: kernel calendar alarms io.streams.duplex ; IN: io.timeouts -TUPLE: lapse entry timeout cutoff ; - -: 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: 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 +M: duplex-stream set-timeout + 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 [ [ ] 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 ( -- ) - timeout-queue get-global dup dlist-empty? [ drop ] [ - 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 ; +: queue-timeout ( obj timeout -- alarm ) + from-now f rot [ timed-out ] curry add-alarm ; : with-timeout ( obj quot -- ) - over begin-timeout keep unqueue-timeout ; inline - -: expiry-thread ( -- ) - expire-timeouts 5000 sleep expiry-thread ; - -: start-expiry-thread ( -- ) - [ expiry-thread ] "I/O expiry" spawn drop ; - -[ start-expiry-thread ] "io.timeouts" add-init-hook + over dup timeout dup [ + queue-timeout slip cancel-alarm + ] [ + 2drop call + ] if ; inline diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 6f79388016..58e3c0ba69 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/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 - [ 250 sleep ] when ; + [ drop f nap drop ] + [ 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 diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index b89b351f9e..eb628156f2 100755 --- a/extra/smtp/server/server.factor +++ b/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 [ accept [ - 60000 stdio get set-timeout + 1 minutes stdio get set-timeout "220 hello\r\n" write flush process global [ flush ] bind