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.
   4 USING: http http.server io kernel math namespaces
   5 continuations calendar sequences assocs hashtables
   6 accessors arrays alarms quotations combinators fry
   7 http.server.redirection furnace assocs.lib urls ;
   8 IN: furnace.callbacks
   9
  10 SYMBOL: responder
  11
  12 TUPLE: callback-responder responder callbacks ;
  13
  14 : <callback-responder> ( responder -- responder' )
  15     H{ } clone callback-responder boa ;
  16
  17 TUPLE: 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
  63 SYMBOL: 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
  81 SYMBOL: 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
  98 M: 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 ;