Fix scoping problem in cont-responder
slava
parent
7f79de6d1f
commit
b64cb2cb75
|
|
@ -1,29 +1,10 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
!
|
||||
! 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
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: http httpd math namespaces io
|
||||
lists strings kernel html hashtables
|
||||
parser generic sequences ;
|
||||
lists strings kernel html hashtables
|
||||
parser generic sequences ;
|
||||
IN: cont-responder
|
||||
|
||||
#! Used inside the session state of responders to indicate whether the
|
||||
#! next request should use the post-refresh-get pattern. It is set to
|
||||
|
|
@ -31,95 +12,95 @@ USING: http httpd math namespaces io
|
|||
SYMBOL: post-refresh-get?
|
||||
|
||||
: expiry-timeout ( -- timeout-seconds )
|
||||
#! Number of seconds to timeout continuations in
|
||||
#! continuation table. This value will need to be
|
||||
#! tuned. I leave it at 24 hours but it can be
|
||||
#! higher/lower as needed. Default to 15 minutes for
|
||||
#! testing.
|
||||
900 ;
|
||||
#! Number of seconds to timeout continuations in
|
||||
#! continuation table. This value will need to be
|
||||
#! tuned. I leave it at 24 hours but it can be
|
||||
#! higher/lower as needed. Default to 15 minutes for
|
||||
#! testing.
|
||||
900 ;
|
||||
|
||||
: get-random-id ( -- id )
|
||||
#! Generate a random id to use for continuation URL's
|
||||
[ "ID" % 32 [ 9 random-int CHAR: 0 + , ] times ] "" make ;
|
||||
#! Generate a random id to use for continuation URL's
|
||||
[ "ID" % 32 [ 9 random-int CHAR: 0 + , ] times ] "" make ;
|
||||
|
||||
SYMBOL: table
|
||||
|
||||
: continuation-table ( -- <hashtable> )
|
||||
#! Return the global table of continuations
|
||||
table global hash ;
|
||||
|
||||
: reset-continuation-table ( -- )
|
||||
#! Create the initial global table
|
||||
continuation-table clear-hash ;
|
||||
#! Return the global table of continuations
|
||||
table get-global ;
|
||||
|
||||
H{ } clone table global set-hash
|
||||
: reset-continuation-table ( -- )
|
||||
#! Create the initial global table
|
||||
continuation-table clear-hash ;
|
||||
|
||||
H{ } clone table set-global
|
||||
|
||||
#! Tuple for holding data related to a continuation.
|
||||
TUPLE: item expire? quot id time-added ;
|
||||
|
||||
: continuation-item ( expire? quot id -- <item> )
|
||||
#! A continuation item is the actual item stored
|
||||
#! in the continuation table. It contains the id,
|
||||
#! quotation/continuation, time added, etc. If
|
||||
#! expire? is true then the continuation will
|
||||
#! be expired after a certain amount of time.
|
||||
millis <item> ;
|
||||
#! A continuation item is the actual item stored
|
||||
#! in the continuation table. It contains the id,
|
||||
#! quotation/continuation, time added, etc. If
|
||||
#! expire? is true then the continuation will
|
||||
#! be expired after a certain amount of time.
|
||||
millis <item> ;
|
||||
|
||||
: seconds>millis ( seconds -- millis )
|
||||
#! Convert a number of seconds to milliseconds
|
||||
1000 * ;
|
||||
#! Convert a number of seconds to milliseconds
|
||||
1000 * ;
|
||||
|
||||
: expired? ( timeout-seconds <item> -- bool )
|
||||
#! Return true if the continuation item is expirable
|
||||
#! and has expired (ie. was added to the table more than
|
||||
#! timeout milliseconds ago).
|
||||
[ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ;
|
||||
#! Return true if the continuation item is expirable
|
||||
#! and has expired (ie. was added to the table more than
|
||||
#! timeout milliseconds ago).
|
||||
[ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ;
|
||||
|
||||
: expire-continuations ( timeout-seconds -- )
|
||||
#! Expire all continuations in the continuation table
|
||||
#! if they are 'timeout-seconds' old (ie. were added
|
||||
#! more than 'timeout-seconds' ago.
|
||||
continuation-table clone [ ( timeout-seconds [[ id item ]] -- )
|
||||
swapd expired? [
|
||||
continuation-table remove-hash
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
] hash-each-with ;
|
||||
#! Expire all continuations in the continuation table
|
||||
#! if they are 'timeout-seconds' old (ie. were added
|
||||
#! more than 'timeout-seconds' ago.
|
||||
continuation-table clone [
|
||||
swapd expired? [
|
||||
continuation-table remove-hash
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
] hash-each-with ;
|
||||
|
||||
: expirable ( quot -- t quot )
|
||||
#! Set the stack up for a register-continuation call
|
||||
#! so that the given quotation is registered that it can
|
||||
#! be expired.
|
||||
t swap ;
|
||||
#! Set the stack up for a register-continuation call
|
||||
#! so that the given quotation is registered that it can
|
||||
#! be expired.
|
||||
t swap ;
|
||||
|
||||
: permanent ( quot -- f quot )
|
||||
#! Set the stack up for a register-continuation call
|
||||
#! so that the given quotation is never expired after
|
||||
#! registration.
|
||||
f swap ;
|
||||
#! Set the stack up for a register-continuation call
|
||||
#! so that the given quotation is never expired after
|
||||
#! registration.
|
||||
f swap ;
|
||||
|
||||
: register-continuation ( expire? quot -- id )
|
||||
#! Store a continuation in the table and associate it with
|
||||
#! a random id. That continuation will be expired after
|
||||
#! a certain period of time if 'expire?' is true.
|
||||
get-random-id
|
||||
[ continuation-item ] keep ( item id -- )
|
||||
[ continuation-table set-hash ] keep ;
|
||||
|
||||
#! Store a continuation in the table and associate it with
|
||||
#! a random id. That continuation will be expired after
|
||||
#! a certain period of time if 'expire?' is true.
|
||||
get-random-id
|
||||
[ continuation-item ] keep ( item id -- )
|
||||
[ continuation-table set-hash ] keep ;
|
||||
|
||||
: register-continuation* ( expire? quots -- id )
|
||||
#! Like register-continuation but registers a quotation
|
||||
#! that will call all quotations in the list, in the order given.
|
||||
concat register-continuation ;
|
||||
#! Like register-continuation but registers a quotation
|
||||
#! that will call all quotations in the list, in the order given.
|
||||
concat register-continuation ;
|
||||
|
||||
: get-continuation-item ( id -- <item> )
|
||||
#! Get the continuation item associated with the id.
|
||||
continuation-table hash ;
|
||||
#! Get the continuation item associated with the id.
|
||||
continuation-table hash ;
|
||||
|
||||
: id>url ( id -- string )
|
||||
#! Convert the continuation id to an URL suitable for
|
||||
#! embedding in an HREF or other HTML.
|
||||
url-encode "?id=" swap append ;
|
||||
#! Convert the continuation id to an URL suitable for
|
||||
#! embedding in an HREF or other HTML.
|
||||
url-encode "?id=" swap append ;
|
||||
|
||||
DEFER: show-final
|
||||
DEFER: show
|
||||
|
|
@ -127,257 +108,262 @@ DEFER: show
|
|||
TUPLE: resume value stdio ;
|
||||
|
||||
: (expired-page-handler) ( alist -- )
|
||||
#! Display a page has expired message.
|
||||
#! TODO: Need to handle this better to enable
|
||||
#! returning back to root continuation.
|
||||
#! Display a page has expired message.
|
||||
#! TODO: Need to handle this better to enable
|
||||
#! returning back to root continuation.
|
||||
<html>
|
||||
<body>
|
||||
<p> "This page has expired." write </p>
|
||||
</body>
|
||||
<body>
|
||||
<p> "This page has expired." write </p>
|
||||
</body>
|
||||
</html> flush ;
|
||||
|
||||
: expired-page-handler ( alist -- )
|
||||
[ (expired-page-handler) ] show-final ;
|
||||
[ (expired-page-handler) ] show-final ;
|
||||
|
||||
: >callable ( quot|interp|f -- interp )
|
||||
dup continuation? [
|
||||
[ continue-with ] cons
|
||||
] when ;
|
||||
dup continuation? [
|
||||
[ continue-with ] cons
|
||||
] when ;
|
||||
|
||||
: get-registered-continuation ( id -- cont )
|
||||
#! Return the continuation or quotation
|
||||
#! associated with the given id.
|
||||
#! TODO: handle expired pages better.
|
||||
expiry-timeout expire-continuations
|
||||
get-continuation-item [
|
||||
item-quot
|
||||
] [
|
||||
[ (expired-page-handler) ]
|
||||
] if* >callable ;
|
||||
#! Return the continuation or quotation
|
||||
#! associated with the given id.
|
||||
#! TODO: handle expired pages better.
|
||||
expiry-timeout expire-continuations
|
||||
get-continuation-item [
|
||||
item-quot
|
||||
] [
|
||||
[ (expired-page-handler) ]
|
||||
] if* >callable ;
|
||||
|
||||
: resume-continuation ( resumed-data id -- )
|
||||
#! Call the continuation associated with the given id,
|
||||
#! with 'value' on the top of the stack.
|
||||
get-registered-continuation call ;
|
||||
#! Call the continuation associated with the given id,
|
||||
#! with 'value' on the top of the stack.
|
||||
get-registered-continuation call ;
|
||||
|
||||
#! Name of the variable holding the continuation used to exit
|
||||
#! back to the httpd responder, returning any generated HTML.
|
||||
SYMBOL: exit-cc
|
||||
|
||||
: exit-continuation ( -- exit )
|
||||
#! Get the current exit continuation
|
||||
exit-cc get ;
|
||||
#! Get the current exit continuation
|
||||
exit-cc get ;
|
||||
|
||||
: call-exit-continuation ( value -- )
|
||||
#! Call the exit continuation, passing it the given value on the
|
||||
#! top of the stack.
|
||||
exit-cc get continue-with ;
|
||||
#! Call the exit continuation, passing it the given value on the
|
||||
#! top of the stack.
|
||||
exit-cc get continue-with ;
|
||||
|
||||
: with-exit-continuation ( quot -- )
|
||||
#! Call the quotation with the variable exit-cc bound such that when
|
||||
#! the exit continuation is called, computation will resume from the
|
||||
#! end of this 'with-exit-continuation' call, with the value passed
|
||||
#! to the exit continuation on the top of the stack.
|
||||
[ exit-cc set call f call-exit-continuation ] callcc1 nip ;
|
||||
#! Call the quotation with the variable exit-cc bound such that when
|
||||
#! the exit continuation is called, computation will resume from the
|
||||
#! end of this 'with-exit-continuation' call, with the value passed
|
||||
#! to the exit continuation on the top of the stack.
|
||||
[ exit-cc set call f call-exit-continuation ] callcc1 nip ;
|
||||
|
||||
#! Name of variable holding the 'callback' continuation, used for
|
||||
#! returning back to previous 'show' calls.
|
||||
SYMBOL: callback-cc
|
||||
|
||||
: store-callback-cc ( -- )
|
||||
#! Store the current continuation in the variable 'callback-cc'
|
||||
#! so it can be returned to later by callbacks. Note that it
|
||||
#! recalls itself when the continuation is called to ensure that
|
||||
#! it resets its value back to the most recent show call.
|
||||
[ ( 0 -- )
|
||||
[ ( 0 1 -- )
|
||||
callback-cc set ( 0 -- )
|
||||
stdio get swap continue-with
|
||||
] callcc1 ( 0 [ ] == )
|
||||
nip
|
||||
dup resume-stdio stdio set resume-value
|
||||
call
|
||||
store-callback-cc stdio get
|
||||
] callcc1 stdio set ;
|
||||
#! Store the current continuation in the variable 'callback-cc'
|
||||
#! so it can be returned to later by callbacks. Note that it
|
||||
#! recalls itself when the continuation is called to ensure that
|
||||
#! it resets its value back to the most recent show call.
|
||||
[ ( 0 -- )
|
||||
[ ( 0 1 -- )
|
||||
callback-cc set ( 0 -- )
|
||||
stdio get swap continue-with
|
||||
] callcc1
|
||||
nip
|
||||
dup resume-stdio stdio set resume-value
|
||||
call
|
||||
store-callback-cc stdio get
|
||||
] callcc1 stdio set ;
|
||||
|
||||
: forward-to-url ( url -- )
|
||||
#! When executed inside a 'show' call, this will force a
|
||||
#! HTTP 302 to occur to instruct the browser to forward to
|
||||
#! the request URL.
|
||||
[
|
||||
"HTTP/1.1 302 Document Moved\nLocation: " % %
|
||||
"\nContent-Length: 0\nContent-Type: text/plain\n\n" %
|
||||
] "" make write "" call-exit-continuation ;
|
||||
#! When executed inside a 'show' call, this will force a
|
||||
#! HTTP 302 to occur to instruct the browser to forward to
|
||||
#! the request URL.
|
||||
[
|
||||
"HTTP/1.1 302 Document Moved\nLocation: " % %
|
||||
"\nContent-Length: 0\nContent-Type: text/plain\n\n" %
|
||||
] "" make write "" call-exit-continuation ;
|
||||
|
||||
: forward-to-id ( id -- )
|
||||
#! When executed inside a 'show' call, this will force a
|
||||
#! HTTP 302 to occur to instruct the browser to forward to
|
||||
#! the request URL.
|
||||
>r "request" get r> id>url append forward-to-url ;
|
||||
#! When executed inside a 'show' call, this will force a
|
||||
#! HTTP 302 to occur to instruct the browser to forward to
|
||||
#! the request URL.
|
||||
>r "request" get r> id>url append forward-to-url ;
|
||||
|
||||
: redirect-to-here ( -- )
|
||||
#! Force a redirect to the client browser so that the browser
|
||||
#! goes to the current point in the code. This forces an URL
|
||||
#! change on the browser so that refreshing that URL will
|
||||
#! immediately run from this code point. This prevents the
|
||||
#! "this request will issue a POST" warning from the browser
|
||||
#! and prevents re-running the previous POST logic. This is
|
||||
#! known as the 'post-refresh-get' pattern.
|
||||
post-refresh-get? get [
|
||||
[
|
||||
expirable register-continuation forward-to-id
|
||||
] callcc1 resume-stdio stdio set
|
||||
] [
|
||||
t post-refresh-get? set
|
||||
] if ;
|
||||
#! Force a redirect to the client browser so that the browser
|
||||
#! goes to the current point in the code. This forces an URL
|
||||
#! change on the browser so that refreshing that URL will
|
||||
#! immediately run from this code point. This prevents the
|
||||
#! "this request will issue a POST" warning from the browser
|
||||
#! and prevents re-running the previous POST logic. This is
|
||||
#! known as the 'post-refresh-get' pattern.
|
||||
post-refresh-get? get [
|
||||
[
|
||||
expirable register-continuation forward-to-id
|
||||
] callcc1 resume-stdio stdio set
|
||||
] [
|
||||
t post-refresh-get? set
|
||||
] if ;
|
||||
|
||||
: (show) ( quot -- namespace )
|
||||
#! See comments for show. The difference is the
|
||||
#! quotation MUST set the content-type using 'serving-html'
|
||||
#! or similar.
|
||||
store-callback-cc redirect-to-here
|
||||
[
|
||||
expirable register-continuation id>url swap
|
||||
with-scope "" call-exit-continuation
|
||||
] callcc1
|
||||
nip dup resume-stdio stdio set resume-value ;
|
||||
|
||||
#! See comments for show. The difference is the
|
||||
#! quotation MUST set the content-type using 'serving-html'
|
||||
#! or similar.
|
||||
store-callback-cc redirect-to-here
|
||||
[
|
||||
expirable register-continuation id>url swap
|
||||
with-scope "" call-exit-continuation
|
||||
] callcc1
|
||||
nip dup resume-stdio stdio set resume-value ;
|
||||
|
||||
: show ( quot -- namespace )
|
||||
#! Call the quotation with the URL associated with the current
|
||||
#! continuation. All output from the quotation goes to the client
|
||||
#! browser. When the URL is later referenced then
|
||||
#! computation will resume from this 'show' call with a namespace on
|
||||
#! the stack containing any query or post parameters.
|
||||
#! NOTE: On return from 'show' the stack is exactly the same as
|
||||
#! initial entry with 'quot' popped off an <namespace> put on. Even
|
||||
#! if the quotation consumes items on the stack.
|
||||
\ serving-html swons (show) ;
|
||||
#! Call the quotation with the URL associated with the current
|
||||
#! continuation. All output from the quotation goes to the client
|
||||
#! browser. When the URL is later referenced then
|
||||
#! computation will resume from this 'show' call with a namespace on
|
||||
#! the stack containing any query or post parameters.
|
||||
#! NOTE: On return from 'show' the stack is exactly the same as
|
||||
#! initial entry with 'quot' popped off an <namespace> put on. Even
|
||||
#! if the quotation consumes items on the stack.
|
||||
\ serving-html swons (show) ;
|
||||
|
||||
: (show-final) ( quot -- namespace )
|
||||
#! See comments for show-final. The difference is the
|
||||
#! quotation MUST set the content-type using 'serving-html'
|
||||
#! or similar.
|
||||
store-callback-cc redirect-to-here
|
||||
with-scope "" call-exit-continuation ;
|
||||
#! See comments for show-final. The difference is the
|
||||
#! quotation MUST set the content-type using 'serving-html'
|
||||
#! or similar.
|
||||
store-callback-cc redirect-to-here
|
||||
with-scope "" call-exit-continuation ;
|
||||
|
||||
: show-final ( quot -- namespace )
|
||||
#! Similar to 'show', except the quotation does not receive the URL
|
||||
#! to resume computation following 'show-final'. No continuation is
|
||||
#! stored for this resumption. As a result, 'show-final' is for use
|
||||
#! when a page is to be displayed with no further action to occur. Its
|
||||
#! use is an optimisation to save having to generate and save a continuation
|
||||
#! in that special case.
|
||||
\ serving-html swons (show-final) ;
|
||||
#! Similar to 'show', except the quotation does not receive the URL
|
||||
#! to resume computation following 'show-final'. No continuation is
|
||||
#! stored for this resumption. As a result, 'show-final' is for use
|
||||
#! when a page is to be displayed with no further action to occur. Its
|
||||
#! use is an optimisation to save having to generate and save a continuation
|
||||
#! in that special case.
|
||||
\ serving-html swons (show-final) ;
|
||||
|
||||
#! Name of variable for holding initial continuation id that starts
|
||||
#! the responder.
|
||||
SYMBOL: root-continuation
|
||||
|
||||
: id-or-root ( -- id )
|
||||
#! Return the continuation id for the current requested continuation
|
||||
#! or the root continuation if no id is supplied.
|
||||
"id" "query" get hash [ root-continuation get ] unless* ;
|
||||
#! Return the continuation id for the current requested continuation
|
||||
#! or the root continuation if no id is supplied.
|
||||
"id" "query" get hash [ root-continuation get ] unless* ;
|
||||
|
||||
: cont-get/post-responder ( id-or-f -- )
|
||||
#! httpd responder that retrieves a continuation and calls it.
|
||||
#! The continuation id must be in a query parameter called 'id'.
|
||||
#! If it does not exist the root continuation is called. If
|
||||
#! no root continuation exists the expired continuation handler
|
||||
#! should be called.
|
||||
drop [
|
||||
"response" get stdio get <resume>
|
||||
id-or-root [
|
||||
resume-continuation
|
||||
] [
|
||||
(expired-page-handler) "" call-exit-continuation
|
||||
] if*
|
||||
] with-exit-continuation drop ;
|
||||
#! httpd responder that retrieves a continuation and calls it.
|
||||
#! The continuation id must be in a query parameter called 'id'.
|
||||
#! If it does not exist the root continuation is called. If
|
||||
#! no root continuation exists the expired continuation handler
|
||||
#! should be called.
|
||||
[
|
||||
drop [
|
||||
"response" get stdio get <resume>
|
||||
id-or-root [
|
||||
resume-continuation
|
||||
] [
|
||||
(expired-page-handler) "" call-exit-continuation
|
||||
] if*
|
||||
] with-exit-continuation drop
|
||||
] with-scope ;
|
||||
|
||||
: callback-quot ( quot -- quot )
|
||||
#! Convert the given quotation so it works as a callback
|
||||
#! by returning a quotation that will pass the original
|
||||
#! quotation to the callback continuation.
|
||||
[ , \ stdio , \ get , \ <resume> , callback-cc get , \ continue-with , ] [ ] make ;
|
||||
#! Convert the given quotation so it works as a callback
|
||||
#! by returning a quotation that will pass the original
|
||||
#! quotation to the callback continuation.
|
||||
[
|
||||
, \ stdio , \ get , \ <resume> , callback-cc get ,
|
||||
\ continue-with ,
|
||||
] [ ] make ;
|
||||
|
||||
: quot-url ( quot -- url )
|
||||
callback-quot expirable register-continuation id>url ;
|
||||
callback-quot expirable register-continuation id>url ;
|
||||
|
||||
: quot-href ( text quot -- )
|
||||
#! Write to standard output an HTML HREF where the href,
|
||||
#! when referenced, will call the quotation and then return
|
||||
#! back to the most recent 'show' call (via the callback-cc).
|
||||
#! The text of the link will be the 'text' argument on the
|
||||
#! stack.
|
||||
<a quot-url =href a> write </a> ;
|
||||
#! Write to standard output an HTML HREF where the href,
|
||||
#! when referenced, will call the quotation and then return
|
||||
#! back to the most recent 'show' call (via the callback-cc).
|
||||
#! The text of the link will be the 'text' argument on the
|
||||
#! stack.
|
||||
<a quot-url =href a> write </a> ;
|
||||
|
||||
: init-session-namespace ( <resume> -- )
|
||||
#! Setup the initial session namespace. Currently this only
|
||||
#! sets the redirect flag so that the initial request of the
|
||||
#! responder will not do a post-refresh-get style redirect.
|
||||
#! This prevents the initial request to a responder from redirecting
|
||||
#! to an URL with a continuation id. This word must be run from
|
||||
#! within the session namespace.
|
||||
f post-refresh-get? set dup resume-stdio stdio set ;
|
||||
#! Setup the initial session namespace. Currently this only
|
||||
#! sets the redirect flag so that the initial request of the
|
||||
#! responder will not do a post-refresh-get style redirect.
|
||||
#! This prevents the initial request to a responder from redirecting
|
||||
#! to an URL with a continuation id. This word must be run from
|
||||
#! within the session namespace.
|
||||
f post-refresh-get? set dup resume-stdio stdio set ;
|
||||
|
||||
: install-cont-responder ( name quot -- )
|
||||
#! Install a cont-responder with the given name
|
||||
#! that will initially run the given quotation.
|
||||
#!
|
||||
#! Convert the quotation so it is run within a session namespace
|
||||
#! and that namespace is initialized first.
|
||||
\ init-session-namespace swons [ , \ with-scope , ] [ ] make
|
||||
[
|
||||
[ cont-get/post-responder ] "get" set
|
||||
[ cont-get/post-responder ] "post" set
|
||||
swap "responder" set
|
||||
permanent register-continuation root-continuation set
|
||||
] make-responder ;
|
||||
#! Install a cont-responder with the given name
|
||||
#! that will initially run the given quotation.
|
||||
#!
|
||||
#! Convert the quotation so it is run within a session namespace
|
||||
#! and that namespace is initialized first.
|
||||
\ init-session-namespace swons [ , \ with-scope , ] [ ] make
|
||||
[
|
||||
[ cont-get/post-responder ] "get" set
|
||||
[ cont-get/post-responder ] "post" set
|
||||
swap "responder" set
|
||||
permanent register-continuation root-continuation set
|
||||
] make-responder ;
|
||||
|
||||
: simple-page ( title quot -- )
|
||||
#! Call the quotation, with all output going to the
|
||||
#! body of an html page with the given title.
|
||||
<html>
|
||||
<head> <title> swap write </title> </head>
|
||||
<body> call </body>
|
||||
</html> ;
|
||||
#! Call the quotation, with all output going to the
|
||||
#! body of an html page with the given title.
|
||||
<html>
|
||||
<head> <title> swap write </title> </head>
|
||||
<body> call </body>
|
||||
</html> ;
|
||||
|
||||
: styled-page ( title stylesheet-quot quot -- )
|
||||
#! Call the quotation, with all output going to the
|
||||
#! body of an html page with the given title. stylesheet-quot
|
||||
#! is called to generate the required stylesheet.
|
||||
<html>
|
||||
<head>
|
||||
<title> rot write </title>
|
||||
swap call
|
||||
</head>
|
||||
<body> call </body>
|
||||
</html> ;
|
||||
#! Call the quotation, with all output going to the
|
||||
#! body of an html page with the given title. stylesheet-quot
|
||||
#! is called to generate the required stylesheet.
|
||||
<html>
|
||||
<head>
|
||||
<title> rot write </title>
|
||||
swap call
|
||||
</head>
|
||||
<body> call </body>
|
||||
</html> ;
|
||||
|
||||
: paragraph ( str -- )
|
||||
#! Output the string as an html paragraph
|
||||
<p> write </p> ;
|
||||
#! Output the string as an html paragraph
|
||||
<p> write </p> ;
|
||||
|
||||
: show-message-page ( message -- )
|
||||
#! Display the message in an HTML page with an OK button.
|
||||
[
|
||||
"Press OK to Continue" [
|
||||
swap paragraph
|
||||
<a =href a> "OK" write </a>
|
||||
] simple-page
|
||||
] show 2drop ;
|
||||
#! Display the message in an HTML page with an OK button.
|
||||
[
|
||||
"Press OK to Continue" [
|
||||
swap paragraph
|
||||
<a =href a> "OK" write </a>
|
||||
] simple-page
|
||||
] show 2drop ;
|
||||
|
||||
: vertical-layout ( list -- )
|
||||
#! Given a list of HTML components, arrange them vertically.
|
||||
<table>
|
||||
#! Given a list of HTML components, arrange them vertically.
|
||||
<table>
|
||||
[ <tr> <td> call </td> </tr> ] each
|
||||
</table> ;
|
||||
</table> ;
|
||||
|
||||
: horizontal-layout ( list -- )
|
||||
#! Given a list of HTML components, arrange them horizontally.
|
||||
<table>
|
||||
<tr "top" =valign tr> [ <td> call </td> ] each </tr>
|
||||
</table> ;
|
||||
#! Given a list of HTML components, arrange them horizontally.
|
||||
<table>
|
||||
<tr "top" =valign tr> [ <td> call </td> ] each </tr>
|
||||
</table> ;
|
||||
|
||||
: button ( label -- )
|
||||
#! Output an HTML submit button with the given label.
|
||||
<input "submit" =type =value input/> ;
|
||||
#! Output an HTML submit button with the given label.
|
||||
<input "submit" =type =value input/> ;
|
||||
|
|
|
|||
|
|
@ -137,14 +137,16 @@ GENERIC: task-container ( task -- vector )
|
|||
[ drop t swap rot set-bit-nth ] hash-each-with ;
|
||||
|
||||
: init-fdsets ( -- read write except )
|
||||
read-fdset get [ read-tasks get init-fdset ] keep
|
||||
write-fdset get [ write-tasks get init-fdset ] keep
|
||||
read-fdset get-global
|
||||
[ read-tasks get-global init-fdset ] keep
|
||||
write-fdset get-global
|
||||
[ write-tasks get-global init-fdset ] keep
|
||||
f ;
|
||||
|
||||
: io-multiplex ( timeout -- )
|
||||
>r FD_SETSIZE init-fdsets r> make-timeval select io-error
|
||||
read-fdset get read-tasks get handle-fdset
|
||||
write-fdset get write-tasks get handle-fdset ;
|
||||
read-fdset get-global read-tasks get-global handle-fdset
|
||||
write-fdset get-global write-tasks get-global handle-fdset ;
|
||||
|
||||
! Readers
|
||||
|
||||
|
|
@ -203,7 +205,7 @@ M: read-task do-io-task ( task -- ? )
|
|||
2drop f
|
||||
] 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 -- )
|
||||
2dup can-read-count? [
|
||||
|
|
@ -258,10 +260,10 @@ M: write-task do-io-task
|
|||
write-step f
|
||||
] 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 -- )
|
||||
dup io-task-fd write-tasks get hash [
|
||||
dup io-task-fd write-tasks get-global hash [
|
||||
dup write-task? [
|
||||
nip io-task-callbacks enque
|
||||
] [
|
||||
|
|
|
|||
Loading…
Reference in New Issue