unmaintained/cont-responder/callbacks.factor

   1 ! Copyright (C) 2004 Chris Double.\r
   2 ! Copyright (C) 2006, 2008 Slava Pestov.\r
   3 ! See http://factorcode.org/license.txt for BSD license.\r
   4 USING: http http.server io kernel math namespaces\r
   5 continuations calendar sequences assocs hashtables\r
   6 accessors arrays alarms quotations combinators fry\r
   7 http.server.redirection furnace assocs.lib urls ;\r
   8 IN: furnace.callbacks\r
   9 \r
  10 SYMBOL: responder\r
  11 \r
  12 TUPLE: callback-responder responder callbacks ;\r
  13 \r
  14 : <callback-responder> ( responder -- responder' )\r
  15     H{ } clone callback-responder boa ;\r
  16 \r
  17 TUPLE: callback cont quot expires alarm responder ;\r
  18 \r
  19 : timeout 20 minutes ;\r
  20 \r
  21 : timeout-callback ( callback -- )\r
  22     [ alarm>> cancel-alarm ]\r
  23     [ dup responder>> callbacks>> delete-at ]\r
  24     bi ;\r
  25 \r
  26 : touch-callback ( callback -- )\r
  27     dup expires>> [\r
  28         dup alarm>> [ cancel-alarm ] when*\r
  29         dup '[ , timeout-callback ] timeout later >>alarm\r
  30     ] when drop ;\r
  31 \r
  32 : <callback> ( cont quot expires? -- callback )\r
  33     f callback-responder get callback boa\r
  34     dup touch-callback ;\r
  35 \r
  36 : invoke-callback ( callback -- response )\r
  37     [ touch-callback ]\r
  38     [ quot>> request get exit-continuation get 3array ]\r
  39     [ cont>> continue-with ]\r
  40     tri ;\r
  41 \r
  42 : register-callback ( cont quot expires? -- id )\r
  43     <callback> callback-responder get callbacks>> set-at-unique ;\r
  44 \r
  45 : forward-to-url ( url -- * )\r
  46     #! When executed inside a 'show' call, this will force a\r
  47     #! HTTP 302 to occur to instruct the browser to forward to\r
  48     #! the request URL.\r
  49     <temporary-redirect> exit-with ;\r
  50 \r
  51 : cont-id "factorcontid" ;\r
  52 \r
  53 : forward-to-id ( id -- * )\r
  54     #! When executed inside a 'show' call, this will force a\r
  55     #! HTTP 302 to occur to instruct the browser to forward to\r
  56     #! the request URL.\r
  57     <url>\r
  58         swap cont-id set-query-param forward-to-url ;\r
  59 \r
  60 : restore-request ( pair -- )\r
  61     first3 exit-continuation set request set call ;\r
  62 \r
  63 SYMBOL: post-refresh-get?\r
  64 \r
  65 : redirect-to-here ( -- )\r
  66     #! Force a redirect to the client browser so that the browser\r
  67     #! goes to the current point in the code. This forces an URL\r
  68     #! change on the browser so that refreshing that URL will\r
  69     #! immediately run from this code point. This prevents the\r
  70     #! "this request will issue a POST" warning from the browser\r
  71     #! and prevents re-running the previous POST logic. This is\r
  72     #! known as the 'post-refresh-get' pattern.\r
  73     post-refresh-get? get [\r
  74         [\r
  75             [ ] t register-callback forward-to-id\r
  76         ] callcc1 restore-request\r
  77     ] [\r
  78         post-refresh-get? on\r
  79     ] if ;\r
  80 \r
  81 SYMBOL: current-show\r
  82 \r
  83 : store-current-show ( -- )\r
  84     #! Store the current continuation in the variable 'current-show'\r
  85     #! so it can be returned to later by 'quot-id'. Note that it\r
  86     #! recalls itself when the continuation is called to ensure that\r
  87     #! it resets its value back to the most recent show call.\r
  88     [ current-show set f ] callcc1\r
  89     [ restore-request store-current-show ] when* ;\r
  90 \r
  91 : show-final ( quot -- * )\r
  92     [ redirect-to-here store-current-show ] dip\r
  93     call exit-with ; inline\r
  94 \r
  95 : resuming-callback ( responder request -- id )\r
  96     url>> cont-id query-param swap callbacks>> at ;\r
  97 \r
  98 M: callback-responder call-responder* ( path responder -- response )\r
  99     '[\r
 100         , ,\r
 101 \r
 102         [ callback-responder set ]\r
 103         [ request get resuming-callback ] bi\r
 104 \r
 105         [\r
 106             invoke-callback\r
 107         ] [\r
 108             callback-responder get responder>> call-responder\r
 109         ] ?if\r
 110     ] with-exit-continuation ;\r
 111 \r
 112 : show-page ( quot -- )\r
 113     [ redirect-to-here store-current-show ] dip\r
 114     [\r
 115         [ ] t register-callback swap call exit-with\r
 116     ] callcc1 restore-request ; inline\r
 117 \r
 118 : quot-id ( quot -- id )\r
 119     current-show get swap t register-callback ;\r
 120 \r
 121 : quot-url ( quot -- url )\r
 122     quot-id f swap cont-id associate derive-url ;\r