/unmaintained/cont-responder/callbacks.factor

  1! Copyright (C) 2004 Chris Double.

  2! Copyright (C) 2006, 2008 Slava Pestov.

  3! See http://factorcode.org/license.txt for BSD license.

  4USING: http http.server io kernel math namespaces
  5continuations calendar sequences assocs hashtables
  6accessors arrays alarms quotations combinators fry
  7http.server.redirection furnace assocs.lib urls ;

  8IN: furnace.callbacks
  9
 10SYMBOL: responder
 11
 12TUPLE: callback-responder responder callbacks ;

 13
 14: <callback-responder> ( responder -- responder' )

 15    H{ } clone callback-responder boa ;

 16
 17TUPLE: callback cont quot expires alarm responder ;

 18
 19: timeout 20 minutes ;

 20
 21: timeout-callback ( callback -- )

 22    [ alarm>> cancel-alarm ]
 23    [ dup responder>> callbacks>> delete-at ]
 24    bi ;

 25
 26: touch-callback ( callback -- )

 27    dup expires>> [
 28        dup alarm>> [ cancel-alarm ] when*

 29        dup '[ , timeout-callback ] timeout later >>alarm
 30    ] when drop ;

 31
 32: <callback> ( cont quot expires? -- callback )

 33    f callback-responder get callback boa

 34    dup touch-callback ;

 35
 36: invoke-callback ( callback -- response )

 37    [ touch-callback ]
 38    [ quot>> request get exit-continuation get 3array ]
 39    [ cont>> continue-with ]
 40    tri ;

 41
 42: register-callback ( cont quot expires? -- id )

 43    <callback> callback-responder get callbacks>> set-at-unique ;

 44
 45: forward-to-url ( url -- * )

 46    #! When executed inside a 'show' call, this will force a

 47    #! HTTP 302 to occur to instruct the browser to forward to

 48    #! the request URL.

 49    <temporary-redirect> exit-with ;

 50
 51: cont-id "factorcontid" ;

 52
 53: forward-to-id ( id -- * )

 54    #! When executed inside a 'show' call, this will force a

 55    #! HTTP 302 to occur to instruct the browser to forward to

 56    #! the request URL.

 57    <url>
 58        swap cont-id set-query-param forward-to-url ;

 59
 60: restore-request ( pair -- )

 61    first3 exit-continuation set request set call ;

 62
 63SYMBOL: post-refresh-get?
 64
 65: redirect-to-here ( -- )

 66    #! Force a redirect to the client browser so that the browser

 67    #! goes to the current point in the code. This forces an URL

 68    #! change on the browser so that refreshing that URL will

 69    #! immediately run from this code point. This prevents the

 70    #! "this request will issue a POST" warning from the browser

 71    #! and prevents re-running the previous POST logic. This is

 72    #! known as the 'post-refresh-get' pattern.

 73    post-refresh-get? get [
 74        [
 75            [ ] t register-callback forward-to-id
 76        ] callcc1 restore-request
 77    ] [
 78        post-refresh-get? on

 79    ] if ;

 80
 81SYMBOL: current-show
 82
 83: store-current-show ( -- )

 84    #! Store the current continuation in the variable 'current-show'

 85    #! so it can be returned to later by 'quot-id'. Note that it

 86    #! recalls itself when the continuation is called to ensure that

 87    #! it resets its value back to the most recent show call.

 88    [ current-show set f ] callcc1

 89    [ restore-request store-current-show ] when* ;

 90
 91: show-final ( quot -- * )

 92    [ redirect-to-here store-current-show ] dip

 93    call exit-with ; inline

 94
 95: resuming-callback ( responder request -- id )

 96    url>> cont-id query-param swap callbacks>> at ;

 97
 98M: callback-responder call-responder* ( path responder -- response )

 99    '[
100        , ,
101
102        [ callback-responder set ]
103        [ request get resuming-callback ] bi

104
105        [
106            invoke-callback
107        ] [
108            callback-responder get responder>> call-responder
109        ] ?if

110    ] with-exit-continuation ;

111
112: show-page ( quot -- )

113    [ redirect-to-here store-current-show ] dip

114    [
115        [ ] t register-callback swap call exit-with
116    ] callcc1 restore-request ; inline

117
118: quot-id ( quot -- id )

119    current-show get swap t register-callback ;

120
121: quot-url ( quot -- url )

122    quot-id f swap cont-id associate derive-url ;