317 lines
11 KiB
Factor
317 lines
11 KiB
Factor
! cont-responder v0.5
|
|
!
|
|
! 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
|
|
USE: stdio
|
|
USE: httpd
|
|
USE: httpd-responder
|
|
USE: arithmetic
|
|
USE: random
|
|
USE: continuations
|
|
USE: format
|
|
USE: namespaces
|
|
USE: stack
|
|
USE: combinators
|
|
USE: streams
|
|
USE: lists
|
|
USE: strings
|
|
USE: html
|
|
USE: kernel
|
|
USE: logic
|
|
USE: cont-html
|
|
|
|
: 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 1 hour for
|
|
#! testing.
|
|
3600 ;
|
|
|
|
: 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 )
|
|
#! Generate a random id to use for continuation URL's
|
|
<% 16 [ random-digit % ] times %> ;
|
|
|
|
: continuation-table ( -- <namespace> )
|
|
#! Return the global table of continuations
|
|
"continuation-table" get ;
|
|
|
|
: reset-continuation-table ( -- )
|
|
#! Create the initial global table
|
|
<namespace> "continuation-table" set ;
|
|
|
|
: 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.
|
|
<namespace> [
|
|
"id" set
|
|
"quot" set
|
|
"expire?" set
|
|
millis "time-added" set
|
|
] extend ;
|
|
|
|
: seconds>millis ( seconds -- millis )
|
|
#! 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).
|
|
[ seconds>millis "time-added" get + millis - 0 <
|
|
"expire?" get and
|
|
] bind ;
|
|
|
|
: continuation-items ( -- alist )
|
|
#! Return an alist of all continuation items in the continuation
|
|
#! table with the car as the id and the cdr as the item.
|
|
continuation-table [ vars-values ] bind ;
|
|
|
|
: 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-items [ cdr dupd expired? not ] subset nip
|
|
alist>namespace "continuation-table" set ;
|
|
|
|
: 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.
|
|
continuation-table [
|
|
get-random-id -rot pick continuation-item over set
|
|
] bind ;
|
|
|
|
: append* ( lists -- list )
|
|
#! Given a list of lists, append the lists together
|
|
#! and return the concatenated list.
|
|
f swap [ append ] each ;
|
|
|
|
: register-continuation* ( expire? quots -- id )
|
|
#! Like register-continuation but registers a quotation
|
|
#! that will call all quotations in the list, in the order given.
|
|
append* register-continuation ;
|
|
|
|
: get-continuation-item ( id -- <item> )
|
|
#! Get the continuation item associated with the id.
|
|
continuation-table [ get ] bind ;
|
|
|
|
DEFER: show
|
|
|
|
: expired-page-handler ( alist -- )
|
|
#! Display a page has expired message.
|
|
#! TODO: Need to handle this better to enable
|
|
#! returning back to root continuation.
|
|
drop
|
|
[
|
|
drop
|
|
<html> [
|
|
<body> [
|
|
<p> [ "This page has expired." write ] </p>
|
|
] </body>
|
|
] </html>
|
|
] show drop ;
|
|
|
|
: 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 dup [
|
|
[ "quot" get ] bind
|
|
] [
|
|
drop [ expired-page-handler ]
|
|
] ifte ;
|
|
|
|
: resume-continuation ( value id -- )
|
|
#! Call the continuation associated with the given id,
|
|
#! with 'value' on the top of the stack.
|
|
get-registered-continuation call ;
|
|
|
|
: exit-continuation ( -- exit )
|
|
#! Get the current exit continuation
|
|
"exit" get ;
|
|
|
|
: call-exit-continuation ( value -- )
|
|
#! Call the exit continuation, passing it the given value on the
|
|
#! top of the stack.
|
|
"exit" get call ;
|
|
|
|
: with-exit-continuation ( quot -- )
|
|
#! Call the quotation with the variable "exit" 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" set call f call-exit-continuation ] callcc1 nip ;
|
|
|
|
: 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 -- )
|
|
call
|
|
] callcc1 ( 0 [ ] == )
|
|
nip
|
|
call
|
|
store-callback-cc
|
|
] callcc0 ;
|
|
|
|
: with-string-stream ( quot -- string )
|
|
#! Call the quotation with standard output bound to a string output
|
|
#! stream. Return the string on exit.
|
|
<namespace> [
|
|
"stdio" 1024 <string-output-stream> put call "stdio" get stream>str
|
|
] bind ;
|
|
|
|
: 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.
|
|
"disable-initial-redirect?" get [
|
|
"disable-initial-redirect?" f put
|
|
] [
|
|
[
|
|
t swap register-continuation
|
|
<% "HTTP/1.1 302 Document Moved\nLocation: " % % "\n" %
|
|
"Content-Length: 0\nContent-Type: text/plain\n\n" % %>
|
|
call-exit-continuation
|
|
] callcc1 drop
|
|
] ifte ;
|
|
|
|
: show ( quot -- namespace )
|
|
#! Call the quotation with the URL associated with the current
|
|
#! continuation. Return the HTML string generated by that code
|
|
#! to the exit continuation. 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.
|
|
store-callback-cc
|
|
redirect-enabled? [ redirect-to-here ] when
|
|
[
|
|
t swap register-continuation swap
|
|
[ serving-html ] car swons with-string-stream
|
|
call-exit-continuation
|
|
] callcc1
|
|
nip ;
|
|
|
|
: cont-get-responder ( id -- )
|
|
#! httpd responder that retrieves a continuation and calls it.
|
|
dup f-or-"" [
|
|
#! No continuation id given
|
|
drop "root-continuation" get dup [
|
|
#! 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
|
|
[ print ] when* drop ;
|
|
|
|
: post-request>alist ( post-request -- alist )
|
|
#! Return an alist containing name/value pairs from the
|
|
#! post data.
|
|
dup "&" swap str-contains? [
|
|
"&" split [ "=" split1 ] inject
|
|
] [
|
|
"=" split1 unit
|
|
] ifte ;
|
|
|
|
: post-request>namespace ( post-request -- namespace )
|
|
#! Return a namespace containing the name/value's from the
|
|
#! post data.
|
|
post-request>alist alist>namespace ;
|
|
|
|
: cont-post-responder ( id -- )
|
|
#! httpd responder that retrieves a continuation for the given
|
|
#! id and calls it with the POST data as an alist on the top
|
|
#! of the stack.
|
|
[
|
|
read-post-request post-request>namespace swap resume-continuation
|
|
] with-exit-continuation
|
|
print drop ;
|
|
|
|
: 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 href=
|
|
unit "callback-cc" get [ call ] cons append t swap register-continuation
|
|
a>
|
|
swap unit [ write ] append </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 ( -- )
|
|
#! Setup the initial session namespace. Currently this only
|
|
#! copies the global value of whether the initial redirect
|
|
#! will be disabled. It assumes the session namespace is
|
|
#! topmost on the namespace stack.
|
|
"disable-initial-redirect?" get "disable-initial-redirect?" set ;
|
|
|
|
: install-cont-responder ( name quot -- )
|
|
#! Install a cont-responder with the given name
|
|
#! that will initially run the given quotation.
|
|
#!
|
|
#! Convert the quotation os it is run within a session namespace
|
|
#! and that namespace is initialized first.
|
|
[ init-session-namespace ] swap append unit [ with-new-session ] append
|
|
"httpd-responders" get [
|
|
<responder> [
|
|
[ cont-get-responder ] "get" set
|
|
[ cont-post-responder ] "post" set
|
|
reset-continuation-table
|
|
"disable-initial-redirect?" t put
|
|
f swap register-continuation "root-continuation" set
|
|
dup "responder-name" set
|
|
] extend put
|
|
] bind ;
|
|
|