steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

tidy up browser title. 

put vocab and word name in browser titlebar.
update cont-responder documentation. Added information on 'show-final'
and updated examples that had suferred code rot (ie. Change use of
times*, succ, pred, [ | ], etc)..
remove setting of responder name in browser. The setting of the name
caused the browser-edit responder to jump to the browser responder when
a word was clicked..
added show-final to cont-responder.
add responder-items word for debugging in cont-responder.
changed expiry of cont-responder continuations. When the continuations
are expired they are now removed from the hash table. Previously each
request would rebuild the continuation table containing the non-expired
continuations..
convert from hashtables to typles in cont-responder.
move to using symbols for variable names in cont-responder.
convert USE: to USING: in cont-responder.
various minor cont-responder refactorings.
refactor init-cont-responder.
merge cont-get-responder and cont-put-responder into one.
refactor cont-get-responder.
fix cont-responder bug involving redirects. When a cont-responder
request for an expired page was made the  'redirect' flag was not
correctly reset. This resulted in initial  requests of a responder
redirecting when it wasn't supposed to.  Tidied up the area of redirects
and post-refresh-get pattern..
added use of show-final to todo-list.
cvs
Chris Double 2005-02-21 00:47:08 +00:00
parent ba492a60d8
commit a0c7e80835
4 changed files with 184 additions and 186 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
contrib/cont-responder/todo-example.factor
View File

@ -106,7 +106,7 @@ USE: kernel
: todo-stylesheet-url ( -- url ) : todo-stylesheet-url ( -- url )
#! Generate an URL for the stylesheet. #! Generate an URL for the stylesheet.
t [ [ drop todo-stylesheet write ] show ] register-continuation id>url ; t [ [ todo-stylesheet write ] show-final ] register-continuation id>url ;
: include-todo-stylesheet ( -- ) : include-todo-stylesheet ( -- )
#! Generate HTML to include the todo stylesheet #! Generate HTML to include the todo stylesheet
@ -476,14 +476,13 @@ USE: kernel
[ "todo" get todo-username , "'s To Do list" , ] make-string [ "todo" get todo-username , "'s To Do list" , ] make-string
[ include-todo-stylesheet ] [ include-todo-stylesheet ]
[ [
drop
"todo" get write-item-table "todo" get write-item-table
[ [
[ "Add Item" [ do-add-new-item ] quot-href ] [ "Add Item" [ do-add-new-item ] quot-href ]
[ "Change Password" [ do-change-password ] quot-href ] [ "Change Password" [ do-change-password ] quot-href ]
] horizontal-layout ] horizontal-layout
] styled-page ] styled-page
] show drop ; ] show-final ;
: todo-example ( path -- ) : todo-example ( path -- )
#! Startup the todo list example using the given path as the #! Startup the todo list example using the given path as the

119
doc/cont-responder-tutorial.txt
View File

@ -37,14 +37,25 @@ gets run when the client accesses a particular URL. When run that word
has 'standard output' bound in such a way that all output goes to the has 'standard output' bound in such a way that all output goes to the
clients web browser. clients web browser.
In the 'cont-responder' system the word used to set output to go to the web In the 'cont-responder' system there are two words used to set output
browser and display a page is 'show'. Think of it as 'show a page to to go to the web browser and display a page. They are 'show' and
the client'. 'show' takes a single item on the stack and that is a 'show-final'. Think of them as 'show a page to the client'. 'show' and
'page generation' quotation. 'show-final' both take a single item on the stack and that is a 'page
generation' quotation.
A 'page generation' quotation is a quotation with stack effect A 'page generation' quotation is a quotation which when called will
( string -- ). For now we'll ignore the string it receives on the output HTML to stdout. In the httpd system, stdout is bound to the
stack. Its purpose will be explained later. socket connection to the clients web browser.
The 'page generation' quotation passed to 'show' should have stack
effect ( string -- ) while that for 'show-final' has stack effect
( -- ). The two words have very similar uses.
The big difference is with 'show'. It provides an URL to the page
generation quotation that when requested will proceed with execution
immediately following the 'show', and any POST request data will be on
the stack. With 'show-final' no URL is passed so it is not possible to
'resume' computation. This is explained more fully later.
Hello World 1 Hello World 1
============= =============
@ -52,16 +63,12 @@ A simple 'hello world' responder would be:
: hello-world1 ( -- ) : hello-world1 ( -- )
[ [
drop
"<html><head><title>Hello World</title></head>" write "<html><head><title>Hello World</title></head>" write
"<body>Hello World!</body></html>" write "<body>Hello World!</body></html>" write
] show drop ; ] show-final ;
When installed this will show a single page which is simple HTML to When installed this will show a single page which is simple HTML to
display 'Hello World!'. The 'show' word returns a namespace, the display 'Hello World!'.
purpose of which will also be explained later. For now we ignore it
and drop it. Notice we also drop the 'URL' that the quotation passed
to 'show' receives on the stack.
The responder is installed using: The responder is installed using:
@ -134,12 +141,11 @@ system:
: hello-world2 ( -- ) : hello-world2 ( -- )
[ [
drop
<html> <html>
<head> <title> "Hello World" write </title> </head> <head> <title> "Hello World" write </title> </head>
<body> "Hello World!" write </body> <body> "Hello World!" write </body>
</html> </html>
] show drop ; ] show-final ;
Install it using: Install it using:
@ -149,14 +155,13 @@ Dynamic Data
============ ============
Adding dynamic data to the page is relatively easy. This example pulls Adding dynamic data to the page is relatively easy. This example pulls
information from the 'room' word which displays memory details about information from the 'room' word which returns memory details about
the running Factor system. It also uses 'room.' which outputs these the running Factor system. It also uses 'room.' which outputs these
details to standard output and this is wrapped in a <pre> tag so it is details to standard output and this is wrapped in a <pre> tag so it is
formatted correctly. formatted correctly.
: memory-stats1 ( -- ) : memory-stats1 ( -- )
[ [
drop
<html> <html>
<head> <title> "Memory Statistics" write </title> </head> <head> <title> "Memory Statistics" write </title> </head>
<body> <body>
@ -181,8 +186,8 @@ formatted correctly.
</body> </body>
<pre> room. </pre> <pre> room. </pre>
</html> </html>
] show drop ; ] show-final ;
"memorystats1" [ memory-stats1 ] install-cont-responder "memorystats1" [ memory-stats1 ] install-cont-responder
Accessing this page will show a table with the current memory Accessing this page will show a table with the current memory
@ -206,12 +211,11 @@ The HTML output can be refactored into different words. For example:
: memory-stats2 ( -- ) : memory-stats2 ( -- )
[ [
drop
<html> <html>
<head> <title> "Memory Statistics 2" write </title> </head> <head> <title> "Memory Statistics 2" write </title> </head>
<body> room memory-stats-table 2drop </body> <body> room memory-stats-table 2drop </body>
</html> </html>
] show drop ; ] show-final ;
"memorystats2" [ memory-stats2 ] install-cont-responder "memorystats2" [ memory-stats2 ] install-cont-responder
@ -234,7 +238,7 @@ procedural flow is maintained.
This brings us to the 'URL' stack item that is available to the 'page This brings us to the 'URL' stack item that is available to the 'page
generation' quotation passed to 'show'. This URL is a string that generation' quotation passed to 'show'. This URL is a string that
contains an URL that can be embedded in the page. When the user access contains an URL that can be embedded in the page. When the user access
that URL computation is resumed from the point of the end of the that URL, computation is resumed from the point of the end of the
'show' call as described above: 'show' call as described above:
: flow-example1 ( -- ) : flow-example1 ( -- )
@ -257,21 +261,23 @@ that URL computation is resumed from the point of the end of the
</html> </html>
] show drop ] show drop
[ [
drop
<html> <html>
<head> <title> "Flow Example 1" write </title> </head> <head> <title> "Flow Example 1" write </title> </head>
<body> <body>
<p> "Page 3" write </p> <p> "Page 3" write </p>
</body> </body>
</html> </html>
] show drop ; ] show-final ;
"flowexample1" [ flow-example1 ] install-cont-responder "flowexample1" [ flow-example1 ] install-cont-responder
The 'flow-example1' word contains three 'show' calls in a row. The The 'flow-example1' word contains two 'show' calls in a row, followed
first two display simple pages with an anchor link to the URL received by a 'show-final'. The 'show' calls display simple pages with an anchor
on the stack. This URL when accessed resumes the computation. The link to the URL received on the stack. This URL when accessed resumes
final page just drops the URL. the computation. The final page doesn't require resumption of the
computation so 'show-final' is used. We could have used 'show' and
dropped the URL passed to the quotation and the result following the
'show' but using 'show-final' is more efficient.
When you display this example in the browser you'll be able to click When you display this example in the browser you'll be able to click
the URL to navigate. You can use the back button to retry the URL's, the URL to navigate. You can use the back button to retry the URL's,
@ -301,14 +307,14 @@ this into a seperate word:
: flow-example2 ( n -- ) : flow-example2 ( n -- )
#! Display the given number of pages in a row. #! Display the given number of pages in a row.
dup pred [ succ t show-flow-page ] times* dup 1 - [ dup 1 + t show-flow-page ] repeat
f show-flow-page ; f show-flow-page ;
"flowexample2" [ 5 flow-example2 ] install-cont-responder "flowexample2" [ 5 flow-example2 ] install-cont-responder
In this example the 'show-flow-age' pulls the page number off the In this example the 'show-flow-page' pulls the page number off the
stack. It also gets whether or not to display the link to the next stack. It also gets whether or not to display the link to the next
page. page.
Notice that after the show that a '3drop' is done whereas Notice that after the show that a '3drop' is done whereas
previously we've only done a single 'drop'. This is due to a side previously we've only done a single 'drop'. This is due to a side
@ -323,15 +329,16 @@ continuation which, when captured, had those items on the stack. The
general rule of thumb is you will need to account for items on the general rule of thumb is you will need to account for items on the
stack before the show call. stack before the show call.
This example also demonstrates using the 'times*' combinator to This example also demonstrates using the 'repeat' combinator to
sequence the page shows. Any Factor code can be called and the sequence the page shows. Any Factor code can be called and the
continuation based system will sequentially display each page. The continuation based system will sequentially display each page. The
back button, browser window cloning, etc will all continue to work. back button, browser window cloning, etc will all continue to work.
You'll notice the URL's in the browser have an 'id' query parameter with You'll notice the URL's in the browser have an 'id' query parameter
a number as its value. This is the 'continuation identifier' which is with a sequence of characters as its value. This is the 'continuation
like a session id except that it identifies not just the data you have identifier' which is like a session id except that it identifies not
stored but your location within the responder as well. just the data you have stored but your location within the responder
as well.
Forms and POST data Forms and POST data
=================== ===================
@ -370,14 +377,13 @@ containing this data. Here is a simple example:
: post-example1 ( -- ) : post-example1 ( -- )
[ [
drop
<html> <html>
<head> <title> "Hello!" write </title> </head> <head> <title> "Hello!" write </title> </head>
<body> <body>
<p> accept-users-name write ", Good to see you!" write </p> <p> accept-users-name write ", Good to see you!" write </p>
</body> </body>
</html> </html>
] show drop ; ] show-final ;
"post-example1" [ post-example1 ] install-cont-responder "post-example1" [ post-example1 ] install-cont-responder
@ -398,23 +404,16 @@ the other way though:
: post-example2 ( -- ) : post-example2 ( -- )
accept-users-name accept-users-name
[ ( name url -- ) [ ( name url -- )
drop
<html> <html>
<head> <title> "Hello!" write </title> </head> <head> <title> "Hello!" write </title> </head>
<body> <body>
<p> write ", Good to see you!" write </p> <p> write ", Good to see you!" write </p>
</body> </body>
</html> </html>
] show 2drop ; ] show-final ;
"post-example2" [ post-example2 ] install-cont-responder "post-example2" [ post-example2 ] install-cont-responder
Either way works. Notice that in the 'post-example2' we had to do a
'2drop' instead of a 'drop' at the end of the show to remove the
additional 'name' that is on the stack. This wasn't needed in
'post-example1' because the 'name' was not on the stack at the time of
the 'show' call.
Associating URL's with words Associating URL's with words
============================ ============================
A web page can contain URL's that when clicked perform some A web page can contain URL's that when clicked perform some
@ -439,23 +438,19 @@ decremented.
: counter-example1 ( - ) : counter-example1 ( - )
#! Display a global counter which can be incremented or decremented #! Display a global counter which can be incremented or decremented
#! using anchors. #! using anchors.
#!
#! We don't need the 'url' argument
[ [
drop
<html> <html>
<head> <head>
<title> "Counter: " write "counter" get unparse dup write </title> <title> "Counter: " write "counter" get unparse dup write </title>
</head> </head>
<body> <body>
<h2> "Counter: " write write </h2> <h2> "Counter: " write write </h2>
<p> "++" [ "counter" get succ "counter" set ] quot-href <p> "++" [ "counter" get 1 + "counter" set ] quot-href
"--" [ "counter" get pred "counter" set ] quot-href "--" [ "counter" get 1 - "counter" set ] quot-href
</p> </p>
</body> </body>
</html> </html>
] show ] show-final ;
drop ;
"counter-example1" [ counter-example1 ] install-cont-responder "counter-example1" [ counter-example1 ] install-cont-responder
@ -495,20 +490,18 @@ rather than a namespace:
: counter-example2 ( count - ) : counter-example2 ( count - )
[ ( count URL -- ) [ ( count URL -- )
drop
<html> <html>
<head> <head>
<title> "Counter: " write dup unparse write </title> <title> "Counter: " write dup unparse write </title>
</head> </head>
<body> <body>
<h2> "Counter: " write dup unparse write </h2> <h2> "Counter: " write dup unparse write </h2>
<p> "++" over [ succ counter-example2 ] cons quot-href <p> "++" over [ 1 + counter-example2 ] cons quot-href
"--" swap [ pred counter-example2 ] cons quot-href "--" swap [ 1 - counter-example2 ] cons quot-href
</p> </p>
</body> </body>
</html> </html>
] show ] show-final ;
drop ;
"counter-example2" [ 0 counter-example2 ] install-cont-responder "counter-example2" [ 0 counter-example2 ] install-cont-responder
@ -517,8 +510,8 @@ to a code quotation that will increment or decrement it then call the
responder again. So if the counter value is '5' the two 'quot-href' responder again. So if the counter value is '5' the two 'quot-href'
calls become the equivalent of: calls become the equivalent of:
"++" [ 5 succ counter-example2 ] cons quot-href "++" [ 5 1 + counter-example2 ] cons quot-href
"--" [ 5 pred counter-example2 ] cons quot-href "--" [ 5 1 - counter-example2 ] cons quot-href
Because it calls itself with the new count value the state is Because it calls itself with the new count value the state is
remembered for that page only. This means that each page has an remembered for that page only. This means that each page has an
@ -547,7 +540,7 @@ very easy:
: show-some-pages ( n -- ) : show-some-pages ( n -- )
#! Display the given number of pages in a row. #! Display the given number of pages in a row.
[ succ show-page ] times* ; [ dup 1 + show-page ] repeat ;
: subroutine-example1 ( -- ) : subroutine-example1 ( -- )
[ [
@ -563,7 +556,7 @@ very easy:
</p> </p>
</body> </body>
</html> </html>
] show drop ; ] show-final ;
"subroutine-example1" [ subroutine-example1 ] install-cont-responder "subroutine-example1" [ subroutine-example1 ] install-cont-responder
@ -666,7 +659,7 @@ Again we skip past the forward:
Now we submit the post data along to the 'action' url: Now we submit the post data along to the 'action' url:
"5456539333180428" [ [ "username" | "Chris" ] ] alist>hash test-cont-click "5456539333180428" [ [[ "username" "Chris" ]] ] alist>hash test-cont-click
=> =>
HTTP/1.0 200 Document follows HTTP/1.0 200 Document follows
Content-Type: text/html Content-Type: text/html

10
library/httpd/browser-responder.factor
View File

@ -78,7 +78,6 @@ errors unparser logging listener url-encoding hashtables memory ;
: write-word-source ( vocab word -- ) : write-word-source ( vocab word -- )
#! Write the source for the given word from the vocab as HTML. #! Write the source for the given word from the vocab as HTML.
<namespace> [ <namespace> [
"responder" "browser" put
"allow-edit?" get [ "Edit" [ "edit-state" t put ] quot-href <br/> ] when "allow-edit?" get [ "Edit" [ "edit-state" t put ] quot-href <br/> ] when
"edit-state" get [ "edit-state" get [
write-editable-word-source write-editable-word-source
@ -187,7 +186,12 @@ errors unparser logging listener url-encoding hashtables memory ;
[ [
<html> <html>
<head> <head>
<title> "Factor Browser" write </title> <title>
"Factor Browser - " write
"current-vocab" get write
" - " write
"current-word" get write
</title>
</head> </head>
<body> <body>
<form name= "main" action= method= "post" form> <form name= "main" action= method= "post" form>
@ -212,7 +216,7 @@ errors unparser logging listener url-encoding hashtables memory ;
[ [
"vocabs" get dup [ ] [ drop "unknown" ] ifte "words" get dup [ ] [ drop "unknown" ] ifte browser-url "vocabs" get dup [ ] [ drop "unknown" ] ifte "words" get dup [ ] [ drop "unknown" ] ifte browser-url
forward-to-url forward-to-url
] show ] show-final
] bind <browser> ; ] bind <browser> ;
: browser-responder ( allow-edit? -- ) : browser-responder ( allow-edit? -- )

236
library/httpd/cont-responder.factor
View File

@ -21,25 +21,14 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: cont-responder IN: cont-responder
USE: stdio USING: stdio httpd httpd-responder math random namespaces streams
USE: httpd lists strings kernel html url-encoding unparser hashtables
USE: httpd-responder parser generic ;
USE: math
USE: random #! Used inside the session state of responders to indicate whether the
USE: namespaces #! next request should use the post-refresh-get pattern. It is set to
USE: streams #! true after each request.
USE: lists SYMBOL: post-refresh-get?
USE: strings
USE: html
USE: kernel
USE: html
USE: logging
USE: url-encoding
USE: unparser
USE: hashtables
USE: parser
USE: prettyprint
USE: inspector
: expiry-timeout ( -- timeout-seconds ) : expiry-timeout ( -- timeout-seconds )
#! Number of seconds to timeout continuations in #! Number of seconds to timeout continuations in
@ -49,22 +38,23 @@ USE: inspector
#! testing. #! testing.
900 ; 900 ;
: redirect-enabled?
#! Set to true if you want the post-redirect-get pattern
#! implemented. See the redirect-to-here word for details.
t ;
: get-random-id ( -- id ) : get-random-id ( -- id )
#! Generate a random id to use for continuation URL's #! Generate a random id to use for continuation URL's
[ 32 [ random-digit unparse , ] times ] make-string str>number 36 >base ; [ 32 [ random-digit unparse , ] times ] make-string str>number 36 >base ;
#! Name of variable holding the table of continuations.
SYMBOL: table
: continuation-table ( -- <namespace> ) : continuation-table ( -- <namespace> )
#! Return the global table of continuations #! Return the global table of continuations
"continuation-table" get ; table get ;
: reset-continuation-table ( -- ) : reset-continuation-table ( -- )
#! Create the initial global table #! Create the initial global table
<namespace> "continuation-table" set ; <namespace> table set ;
#! Tuple for holding data related to a continuation.
TUPLE: item expire? quot id time-added ;
: continuation-item ( expire? quot id -- <item> ) : continuation-item ( expire? quot id -- <item> )
#! A continuation item is the actual item stored #! A continuation item is the actual item stored
@ -72,12 +62,7 @@ USE: inspector
#! quotation/continuation, time added, etc. If #! quotation/continuation, time added, etc. If
#! expire? is true then the continuation will #! expire? is true then the continuation will
#! be expired after a certain amount of time. #! be expired after a certain amount of time.
<namespace> [ millis <item> ;
"id" set
"quot" set
"expire?" set
millis "time-added" set
] extend ;
: seconds>millis ( seconds -- millis ) : seconds>millis ( seconds -- millis )
#! Convert a number of seconds to milliseconds #! Convert a number of seconds to milliseconds
@ -87,9 +72,7 @@ USE: inspector
#! Return true if the continuation item is expirable #! Return true if the continuation item is expirable
#! and has expired (ie. was added to the table more than #! and has expired (ie. was added to the table more than
#! timeout milliseconds ago). #! timeout milliseconds ago).
[ seconds>millis "time-added" get + millis - 0 < [ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ;
"expire?" get and
] bind ;
: continuation-items ( -- alist ) : continuation-items ( -- alist )
#! Return an alist of all continuation items in the continuation #! Return an alist of all continuation items in the continuation
@ -100,16 +83,31 @@ USE: inspector
#! 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-items [ cdr dupd expired? not ] subset nip continuation-items [
alist>hash "continuation-table" set ; uncons pick swap expired? [
continuation-table remove-hash
] [
drop
] ifte
] each drop ;
: 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 ;
: 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 ;
: register-continuation ( expire? quot -- id ) : register-continuation ( expire? quot -- id )
#! Store a continuation in the table and associate it with #! Store a continuation in the table and associate it with
#! a random id. That continuation will be expired after #! a random id. That continuation will be expired after
#! a certain period of time if 'expire?' is true. #! a certain period of time if 'expire?' is true.
continuation-table [ get-random-id -rot pick continuation-item over continuation-table set-hash ;
get-random-id -rot pick continuation-item over set
] bind ;
: append* ( lists -- list ) : append* ( lists -- list )
#! Given a list of lists, append the lists together #! Given a list of lists, append the lists together
@ -123,13 +121,14 @@ USE: inspector
: get-continuation-item ( id -- <item> ) : get-continuation-item ( id -- <item> )
#! Get the continuation item associated with the id. #! Get the continuation item associated with the id.
continuation-table [ get ] bind ; continuation-table hash ;
: id>url ( id -- string ) : id>url ( id -- string )
#! Convert the continuation id to an URL suitable for #! Convert the continuation id to an URL suitable for
#! embedding in an HREF or other HTML. #! embedding in an HREF or other HTML.
url-encode "?id=" swap cat2 ; url-encode "?id=" swap cat2 ;
DEFER: show-final
DEFER: show DEFER: show
: expired-page-handler ( alist -- ) : expired-page-handler ( alist -- )
@ -138,45 +137,52 @@ DEFER: show
#! returning back to root continuation. #! returning back to root continuation.
drop drop
[ [
drop
<html> <html>
<body> <body>
<p> "This page has expired." write </p> <p> "This page has expired." write </p>
</body> </body>
</html> </html>
] show drop ; ] show-final ;
: get-registered-continuation ( id -- cont ) : get-registered-continuation ( id -- cont )
#! Return the continuation or quotation #! Return the continuation or quotation
#! associated with the given id. #! associated with the given id.
#! TODO: handle expired pages better. #! TODO: handle expired pages better.
expiry-timeout expire-continuations expiry-timeout expire-continuations
get-continuation-item dup [ get-continuation-item [
[ "quot" get ] bind item-quot
] [ ] [
drop [ expired-page-handler ] [ expired-page-handler ]
] ifte ; ] ifte* ;
: resume-continuation ( value id -- ) : resume-continuation ( value id -- )
#! Call the continuation associated with the given id, #! Call the continuation associated with the given id,
#! with 'value' on the top of the stack. #! with 'value' on the top of the stack.
get-registered-continuation call ; 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 ) : exit-continuation ( -- exit )
#! Get the current exit continuation #! Get the current exit continuation
"exit" get ; exit-cc get ;
: call-exit-continuation ( value -- ) : call-exit-continuation ( value -- )
#! Call the exit continuation, passing it the given value on the #! Call the exit continuation, passing it the given value on the
#! top of the stack. #! top of the stack.
"exit" get call ; exit-cc get call ;
: with-exit-continuation ( quot -- ) : with-exit-continuation ( quot -- )
#! Call the quotation with the variable "exit" bound such that when #! Call the quotation with the variable exit-cc bound such that when
#! the exit continuation is called, computation will resume from the #! the exit continuation is called, computation will resume from the
#! end of this 'with-exit-continuation' call, with the value passed #! end of this 'with-exit-continuation' call, with the value passed
#! to the exit continuation on the top of the stack. #! to the exit continuation on the top of the stack.
[ "exit" set call f call-exit-continuation ] callcc1 nip ; [ 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-callback-cc ( -- )
#! Store the current continuation in the variable 'callback-cc' #! Store the current continuation in the variable 'callback-cc'
@ -185,7 +191,7 @@ DEFER: show
#! it resets its value back to the most recent show call. #! it resets its value back to the most recent show call.
[ ( 0 -- ) [ ( 0 -- )
[ ( 0 1 -- ) [ ( 0 1 -- )
"callback-cc" set ( 0 -- ) callback-cc set ( 0 -- )
call call
] callcc1 ( 0 [ ] == ) ] callcc1 ( 0 [ ] == )
nip nip
@ -215,15 +221,13 @@ DEFER: show
#! "this request will issue a POST" warning from the browser #! "this request will issue a POST" warning from the browser
#! and prevents re-running the previous POST logic. This is #! and prevents re-running the previous POST logic. This is
#! known as the 'post-refresh-get' pattern. #! known as the 'post-refresh-get' pattern.
"disable-initial-redirect?" get [ post-refresh-get? get [
"disable-initial-redirect?" f put
] [
[ [
t swap register-continuation expirable register-continuation
[ "HTTP/1.1 302 Document Moved\nLocation: " , id>url , "\n" , id>url forward-to-url
"Content-Length: 0\nContent-Type: text/plain\n\n" , ] make-string
call-exit-continuation
] callcc1 drop ] callcc1 drop
] [
t post-refresh-get? set
] ifte ; ] ifte ;
: show ( quot -- namespace ) : show ( quot -- namespace )
@ -235,51 +239,52 @@ DEFER: show
#! NOTE: On return from 'show' the stack is exactly the same as #! NOTE: On return from 'show' the stack is exactly the same as
#! initial entry with 'quot' popped off an <namespace> put on. Even #! initial entry with 'quot' popped off an <namespace> put on. Even
#! if the quotation consumes items on the stack. #! if the quotation consumes items on the stack.
store-callback-cc store-callback-cc redirect-to-here
redirect-enabled? [ redirect-to-here ] when
[ [
t swap register-continuation id>url swap expirable register-continuation id>url swap
[ serving-html ] car swons with-string-stream \ serving-html swons with-string-stream call-exit-continuation
call-exit-continuation
] callcc1 ] callcc1
nip ; nip ;
: 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.
store-callback-cc redirect-to-here
\ serving-html swons with-string-stream call-exit-continuation ;
: cont-get-responder ( id-or-f -- ) #! 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 assoc [ root-continuation get ] unless* ;
: cont-get/post-responder ( id-or-f -- )
#! httpd responder that retrieves a continuation and calls it. #! httpd responder that retrieves a continuation and calls it.
drop #! The continuation id must be in a query parameter called 'id'.
"id" "query" get assoc #! If it does not exist the root continuation is called. If
dup f-or-"" [ #! no root continuation exists the expired continuation handler
#! No continuation id given #! should be called.
drop "root-continuation" get dup [ drop [
#! Use the root continuation
[ f swap resume-continuation ] with-exit-continuation
] [
#! No root continuation either
drop [ f expired-page-handler ] with-exit-continuation
] ifte
] [
#! Use the given continuation
[ f swap resume-continuation ] with-exit-continuation
] ifte
[ write flush ] when* drop ;
: cont-post-responder ( id -- )
#! httpd responder that retrieves a continuation for the given
#! id and calls it with the POST data as a hashtable on the top
#! of the stack.
[
drop
"response" get alist>hash "response" get alist>hash
"id" "query" get assoc resume-continuation id-or-root [
] with-exit-continuation resume-continuation
print drop ; ] [
expired-page-handler
] ifte*
] with-exit-continuation [ write flush ] when* ;
: 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.
unit "callback-cc" get [ call ] cons append ; [ , callback-cc get , \ call , ] make-list ;
: quot-href ( text quot -- ) : quot-href ( text quot -- )
#! Write to standard output an HTML HREF where the href, #! Write to standard output an HTML HREF where the href,
@ -287,20 +292,16 @@ DEFER: show
#! back to the most recent 'show' call (via the callback-cc). #! back to the most recent 'show' call (via the callback-cc).
#! The text of the link will be the 'text' argument on the #! The text of the link will be the 'text' argument on the
#! stack. #! stack.
<a href= callback-quot t swap register-continuation id>url a> write </a> ; <a href= callback-quot expirable register-continuation id>url a> write </a> ;
: with-new-session ( quot -- )
#! Each cont-responder is bound inside their own
#! namespace for storing session state. Run the given
#! quotation inside a new namespace for this purpose.
<namespace> swap bind ;
: init-session-namespace ( -- ) : init-session-namespace ( -- )
#! Setup the initial session namespace. Currently this only #! Setup the initial session namespace. Currently this only
#! copies the global value of whether the initial redirect #! sets the redirect flag so that the initial request of the
#! will be disabled. It assumes the session namespace is #! responder will not do a post-refresh-get style redirect.
#! topmost on the namespace stack. #! This prevents the initial request to a responder from redirecting
"disable-initial-redirect?" get "disable-initial-redirect?" set ; #! to an URL with a continuation id. This word must be run from
#! within the session namespace.
f post-refresh-get? set ;
: install-cont-responder ( name quot -- ) : install-cont-responder ( name quot -- )
#! Install a cont-responder with the given name #! Install a cont-responder with the given name
@ -308,20 +309,21 @@ DEFER: show
#! #!
#! Convert the quotation so it is run within a session namespace #! Convert the quotation so it is run within a session namespace
#! and that namespace is initialized first. #! and that namespace is initialized first.
[ init-session-namespace ] swap append unit [ with-new-session ] append \ init-session-namespace swons [ , \ with-scope , ] make-list
"httpd-responders" get [ <responder> [
<responder> [ [ cont-get/post-responder ] "get" set
[ cont-get-responder ] "get" set [ cont-get/post-responder ] "post" set
[ cont-post-responder ] "post" set over "responder-name" set
over "responder-name" set over "responder" set
over "responder" set reset-continuation-table
reset-continuation-table permanent register-continuation root-continuation set
"disable-initial-redirect?" t put ] extend swap "httpd-responders" get set-hash ;
] extend dup >r rot set
r> [ : responder-items ( name -- items )
f swap register-continuation "root-continuation" set #! Return the table of continuation items for a given responder.
] bind #! Useful for debugging.
] bind ; "httpd-responders" get hash [ continuation-table ] bind ;
: simple-page ( title quot -- ) : simple-page ( title quot -- )
#! Call the quotation, with all output going to the #! Call the quotation, with all output going to the