Fix scoping problem in cont-responder
parent
7f79de6d1f
commit
b64cb2cb75
|
|
@ -1,29 +1,10 @@
|
||||||
! Copyright (C) 2004 Chris Double.
|
! Copyright (C) 2004 Chris Double.
|
||||||
!
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
! Redistribution and use in source and binary forms, with or without
|
|
||||||
! modification, are permitted provided that the following conditions are met:
|
|
||||||
!
|
|
||||||
! 1. Redistributions of source code must retain the above copyright notice,
|
|
||||||
! this list of conditions and the following disclaimer.
|
|
||||||
!
|
|
||||||
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
|
||||||
! this list of conditions and the following disclaimer in the documentation
|
|
||||||
! and/or other materials provided with the distribution.
|
|
||||||
!
|
|
||||||
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
|
||||||
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
|
||||||
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
|
||||||
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
|
||||||
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
|
||||||
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
|
||||||
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
|
||||||
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
|
||||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
|
||||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
IN: cont-responder
|
|
||||||
USING: http httpd math namespaces io
|
USING: http httpd math namespaces io
|
||||||
lists strings kernel html hashtables
|
lists strings kernel html hashtables
|
||||||
parser generic sequences ;
|
parser generic sequences ;
|
||||||
|
IN: cont-responder
|
||||||
|
|
||||||
#! Used inside the session state of responders to indicate whether the
|
#! Used inside the session state of responders to indicate whether the
|
||||||
#! next request should use the post-refresh-get pattern. It is set to
|
#! next request should use the post-refresh-get pattern. It is set to
|
||||||
|
|
@ -46,13 +27,13 @@ SYMBOL: table
|
||||||
|
|
||||||
: continuation-table ( -- <hashtable> )
|
: continuation-table ( -- <hashtable> )
|
||||||
#! Return the global table of continuations
|
#! Return the global table of continuations
|
||||||
table global hash ;
|
table get-global ;
|
||||||
|
|
||||||
: reset-continuation-table ( -- )
|
: reset-continuation-table ( -- )
|
||||||
#! Create the initial global table
|
#! Create the initial global table
|
||||||
continuation-table clear-hash ;
|
continuation-table clear-hash ;
|
||||||
|
|
||||||
H{ } clone table global set-hash
|
H{ } clone table set-global
|
||||||
|
|
||||||
#! Tuple for holding data related to a continuation.
|
#! Tuple for holding data related to a continuation.
|
||||||
TUPLE: item expire? quot id time-added ;
|
TUPLE: item expire? quot id time-added ;
|
||||||
|
|
@ -79,7 +60,7 @@ TUPLE: item expire? quot id time-added ;
|
||||||
#! Expire all continuations in the continuation table
|
#! Expire all continuations in the continuation table
|
||||||
#! if they are 'timeout-seconds' old (ie. were added
|
#! if they are 'timeout-seconds' old (ie. were added
|
||||||
#! more than 'timeout-seconds' ago.
|
#! more than 'timeout-seconds' ago.
|
||||||
continuation-table clone [ ( timeout-seconds [[ id item ]] -- )
|
continuation-table clone [
|
||||||
swapd expired? [
|
swapd expired? [
|
||||||
continuation-table remove-hash
|
continuation-table remove-hash
|
||||||
] [
|
] [
|
||||||
|
|
@ -193,7 +174,7 @@ SYMBOL: callback-cc
|
||||||
[ ( 0 1 -- )
|
[ ( 0 1 -- )
|
||||||
callback-cc set ( 0 -- )
|
callback-cc set ( 0 -- )
|
||||||
stdio get swap continue-with
|
stdio get swap continue-with
|
||||||
] callcc1 ( 0 [ ] == )
|
] callcc1
|
||||||
nip
|
nip
|
||||||
dup resume-stdio stdio set resume-value
|
dup resume-stdio stdio set resume-value
|
||||||
call
|
call
|
||||||
|
|
@ -284,6 +265,7 @@ SYMBOL: root-continuation
|
||||||
#! If it does not exist the root continuation is called. If
|
#! If it does not exist the root continuation is called. If
|
||||||
#! no root continuation exists the expired continuation handler
|
#! no root continuation exists the expired continuation handler
|
||||||
#! should be called.
|
#! should be called.
|
||||||
|
[
|
||||||
drop [
|
drop [
|
||||||
"response" get stdio get <resume>
|
"response" get stdio get <resume>
|
||||||
id-or-root [
|
id-or-root [
|
||||||
|
|
@ -291,13 +273,17 @@ SYMBOL: root-continuation
|
||||||
] [
|
] [
|
||||||
(expired-page-handler) "" call-exit-continuation
|
(expired-page-handler) "" call-exit-continuation
|
||||||
] if*
|
] if*
|
||||||
] with-exit-continuation drop ;
|
] with-exit-continuation drop
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
: callback-quot ( quot -- quot )
|
: callback-quot ( quot -- quot )
|
||||||
#! Convert the given quotation so it works as a callback
|
#! Convert the given quotation so it works as a callback
|
||||||
#! by returning a quotation that will pass the original
|
#! by returning a quotation that will pass the original
|
||||||
#! quotation to the callback continuation.
|
#! quotation to the callback continuation.
|
||||||
[ , \ stdio , \ get , \ <resume> , callback-cc get , \ continue-with , ] [ ] make ;
|
[
|
||||||
|
, \ stdio , \ get , \ <resume> , callback-cc get ,
|
||||||
|
\ continue-with ,
|
||||||
|
] [ ] make ;
|
||||||
|
|
||||||
: quot-url ( quot -- url )
|
: quot-url ( quot -- url )
|
||||||
callback-quot expirable register-continuation id>url ;
|
callback-quot expirable register-continuation id>url ;
|
||||||
|
|
|
||||||
|
|
@ -137,14 +137,16 @@ GENERIC: task-container ( task -- vector )
|
||||||
[ drop t swap rot set-bit-nth ] hash-each-with ;
|
[ drop t swap rot set-bit-nth ] hash-each-with ;
|
||||||
|
|
||||||
: init-fdsets ( -- read write except )
|
: init-fdsets ( -- read write except )
|
||||||
read-fdset get [ read-tasks get init-fdset ] keep
|
read-fdset get-global
|
||||||
write-fdset get [ write-tasks get init-fdset ] keep
|
[ read-tasks get-global init-fdset ] keep
|
||||||
|
write-fdset get-global
|
||||||
|
[ write-tasks get-global init-fdset ] keep
|
||||||
f ;
|
f ;
|
||||||
|
|
||||||
: io-multiplex ( timeout -- )
|
: io-multiplex ( timeout -- )
|
||||||
>r FD_SETSIZE init-fdsets r> make-timeval select io-error
|
>r FD_SETSIZE init-fdsets r> make-timeval select io-error
|
||||||
read-fdset get read-tasks get handle-fdset
|
read-fdset get-global read-tasks get-global handle-fdset
|
||||||
write-fdset get write-tasks get handle-fdset ;
|
write-fdset get-global write-tasks get-global handle-fdset ;
|
||||||
|
|
||||||
! Readers
|
! Readers
|
||||||
|
|
||||||
|
|
@ -203,7 +205,7 @@ M: read-task do-io-task ( task -- ? )
|
||||||
2drop f
|
2drop f
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: read-task task-container drop read-tasks get ;
|
M: read-task task-container drop read-tasks get-global ;
|
||||||
|
|
||||||
: wait-to-read ( count port -- )
|
: wait-to-read ( count port -- )
|
||||||
2dup can-read-count? [
|
2dup can-read-count? [
|
||||||
|
|
@ -258,10 +260,10 @@ M: write-task do-io-task
|
||||||
write-step f
|
write-step f
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: write-task task-container drop write-tasks get ;
|
M: write-task task-container drop write-tasks get-global ;
|
||||||
|
|
||||||
: add-write-io-task ( callback task -- )
|
: add-write-io-task ( callback task -- )
|
||||||
dup io-task-fd write-tasks get hash [
|
dup io-task-fd write-tasks get-global hash [
|
||||||
dup write-task? [
|
dup write-task? [
|
||||||
nip io-task-callbacks enque
|
nip io-task-callbacks enque
|
||||||
] [
|
] [
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue