-! Copyright (C) 2004 Chris Double.\r
-! Copyright (C) 2006, 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: http http.server io kernel math namespaces\r
-continuations calendar sequences assocs hashtables\r
-accessors arrays alarms quotations combinators fry\r
-http.server.redirection furnace assocs.lib urls ;\r
-IN: furnace.callbacks\r
-\r
-SYMBOL: responder\r
-\r
-TUPLE: callback-responder responder callbacks ;\r
-\r
-: <callback-responder> ( responder -- responder' )\r
- H{ } clone callback-responder boa ;\r
-\r
-TUPLE: callback cont quot expires alarm responder ;\r
-\r
-: timeout 20 minutes ;\r
-\r
-: timeout-callback ( callback -- )\r
- [ alarm>> cancel-alarm ]\r
- [ dup responder>> callbacks>> delete-at ]\r
- bi ;\r
-\r
-: touch-callback ( callback -- )\r
- dup expires>> [\r
- dup alarm>> [ cancel-alarm ] when*\r
- dup '[ , timeout-callback ] timeout later >>alarm\r
- ] when drop ;\r
-\r
-: <callback> ( cont quot expires? -- callback )\r
- f callback-responder get callback boa\r
- dup touch-callback ;\r
-\r
-: invoke-callback ( callback -- response )\r
- [ touch-callback ]\r
- [ quot>> request get exit-continuation get 3array ]\r
- [ cont>> continue-with ]\r
- tri ;\r
-\r
-: register-callback ( cont quot expires? -- id )\r
- <callback> callback-responder get callbacks>> set-at-unique ;\r
-\r
-: forward-to-url ( url -- * )\r
- #! When executed inside a 'show' call, this will force a\r
- #! HTTP 302 to occur to instruct the browser to forward to\r
- #! the request URL.\r
- <temporary-redirect> exit-with ;\r
-\r
-: cont-id "factorcontid" ;\r
-\r
-: forward-to-id ( id -- * )\r
- #! When executed inside a 'show' call, this will force a\r
- #! HTTP 302 to occur to instruct the browser to forward to\r
- #! the request URL.\r
- <url>\r
- swap cont-id set-query-param forward-to-url ;\r
-\r
-: restore-request ( pair -- )\r
- first3 exit-continuation set request set call ;\r
-\r
-SYMBOL: post-refresh-get?\r
-\r
-: redirect-to-here ( -- )\r
- #! Force a redirect to the client browser so that the browser\r
- #! goes to the current point in the code. This forces an URL\r
- #! change on the browser so that refreshing that URL will\r
- #! immediately run from this code point. This prevents the\r
- #! "this request will issue a POST" warning from the browser\r
- #! and prevents re-running the previous POST logic. This is\r
- #! known as the 'post-refresh-get' pattern.\r
- post-refresh-get? get [\r
- [\r
- [ ] t register-callback forward-to-id\r
- ] callcc1 restore-request\r
- ] [\r
- post-refresh-get? on\r
- ] if ;\r
-\r
-SYMBOL: current-show\r
-\r
-: store-current-show ( -- )\r
- #! Store the current continuation in the variable 'current-show'\r
- #! so it can be returned to later by 'quot-id'. Note that it\r
- #! recalls itself when the continuation is called to ensure that\r
- #! it resets its value back to the most recent show call.\r
- [ current-show set f ] callcc1\r
- [ restore-request store-current-show ] when* ;\r
-\r
-: show-final ( quot -- * )\r
- [ redirect-to-here store-current-show ] dip\r
- call exit-with ; inline\r
-\r
-: resuming-callback ( responder request -- id )\r
- url>> cont-id query-param swap callbacks>> at ;\r
-\r
-M: callback-responder call-responder* ( path responder -- response )\r
- '[\r
- , ,\r
-\r
- [ callback-responder set ]\r
- [ request get resuming-callback ] bi\r
-\r
- [\r
- invoke-callback\r
- ] [\r
- callback-responder get responder>> call-responder\r
- ] ?if\r
- ] with-exit-continuation ;\r
-\r
-: show-page ( quot -- )\r
- [ redirect-to-here store-current-show ] dip\r
- [\r
- [ ] t register-callback swap call exit-with\r
- ] callcc1 restore-request ; inline\r
-\r
-: quot-id ( quot -- id )\r
- current-show get swap t register-callback ;\r
-\r
-: quot-url ( quot -- url )\r
- quot-id f swap cont-id associate derive-url ;\r
+! 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 ;
projects / factor.git / blobdiff