123 lines
3.8 KiB
Factor
Executable File
123 lines
3.8 KiB
Factor
Executable File
! Copyright (C) 2004 Chris Double.
|
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: http http.server io kernel math namespaces
|
|
continuations calendar sequences assocs hashtables
|
|
accessors arrays alarms quotations combinators fry
|
|
http.server.redirection furnace assocs.lib urls ;
|
|
IN: furnace.callbacks
|
|
|
|
SYMBOL: responder
|
|
|
|
TUPLE: callback-responder responder callbacks ;
|
|
|
|
: <callback-responder> ( responder -- responder' )
|
|
H{ } clone callback-responder boa ;
|
|
|
|
TUPLE: callback cont quot expires alarm responder ;
|
|
|
|
: timeout 20 minutes ;
|
|
|
|
: timeout-callback ( callback -- )
|
|
[ alarm>> cancel-alarm ]
|
|
[ dup responder>> callbacks>> delete-at ]
|
|
bi ;
|
|
|
|
: touch-callback ( callback -- )
|
|
dup expires>> [
|
|
dup alarm>> [ cancel-alarm ] when*
|
|
dup '[ , timeout-callback ] timeout later >>alarm
|
|
] when drop ;
|
|
|
|
: <callback> ( cont quot expires? -- callback )
|
|
f callback-responder get callback boa
|
|
dup touch-callback ;
|
|
|
|
: invoke-callback ( callback -- response )
|
|
[ touch-callback ]
|
|
[ quot>> request get exit-continuation get 3array ]
|
|
[ cont>> continue-with ]
|
|
tri ;
|
|
|
|
: register-callback ( cont quot expires? -- id )
|
|
<callback> callback-responder get callbacks>> set-at-unique ;
|
|
|
|
: 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.
|
|
<temporary-redirect> exit-with ;
|
|
|
|
: cont-id "factorcontid" ;
|
|
|
|
: 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.
|
|
<url>
|
|
swap cont-id set-query-param forward-to-url ;
|
|
|
|
: restore-request ( pair -- )
|
|
first3 exit-continuation set request set call ;
|
|
|
|
SYMBOL: post-refresh-get?
|
|
|
|
: 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 [
|
|
[
|
|
[ ] t register-callback forward-to-id
|
|
] callcc1 restore-request
|
|
] [
|
|
post-refresh-get? on
|
|
] if ;
|
|
|
|
SYMBOL: current-show
|
|
|
|
: store-current-show ( -- )
|
|
#! Store the current continuation in the variable 'current-show'
|
|
#! so it can be returned to later by 'quot-id'. Note that it
|
|
#! recalls itself when the continuation is called to ensure that
|
|
#! it resets its value back to the most recent show call.
|
|
[ current-show set f ] callcc1
|
|
[ restore-request store-current-show ] when* ;
|
|
|
|
: show-final ( quot -- * )
|
|
[ redirect-to-here store-current-show ] dip
|
|
call exit-with ; inline
|
|
|
|
: resuming-callback ( responder request -- id )
|
|
url>> cont-id query-param swap callbacks>> at ;
|
|
|
|
M: callback-responder call-responder* ( path responder -- response )
|
|
'[
|
|
, ,
|
|
|
|
[ callback-responder set ]
|
|
[ request get resuming-callback ] bi
|
|
|
|
[
|
|
invoke-callback
|
|
] [
|
|
callback-responder get responder>> call-responder
|
|
] ?if
|
|
] with-exit-continuation ;
|
|
|
|
: show-page ( quot -- )
|
|
[ redirect-to-here store-current-show ] dip
|
|
[
|
|
[ ] t register-callback swap call exit-with
|
|
] callcc1 restore-request ; inline
|
|
|
|
: quot-id ( quot -- id )
|
|
current-show get swap t register-callback ;
|
|
|
|
: quot-url ( quot -- url )
|
|
quot-id f swap cont-id associate derive-url ;
|