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 ;
12 TUPLE: callback-responder responder callbacks ;
14 : <callback-responder> ( responder -- responder' )
15 H{ } clone callback-responder boa ;
17 TUPLE: callback cont quot expires alarm responder ;
19 : timeout 20 minutes ;
21 : timeout-callback ( callback -- )
22 [ alarm>> cancel-alarm ]
23 [ dup responder>> callbacks>> delete-at ]
26 : touch-callback ( callback -- )
28 dup alarm>> [ cancel-alarm ] when*
29 dup '[ , timeout-callback ] timeout later >>alarm
32 : <callback> ( cont quot expires? -- callback )
33 f callback-responder get callback boa
36 : invoke-callback ( callback -- response )
38 [ quot>> request get exit-continuation get 3array ]
39 [ cont>> continue-with ]
42 : register-callback ( cont quot expires? -- id )
43 <callback> callback-responder get callbacks>> set-at-unique ;
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
49 <temporary-redirect> exit-with ;
51 : cont-id "factorcontid" ;
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
58 swap cont-id set-query-param forward-to-url ;
60 : restore-request ( pair -- )
61 first3 exit-continuation set request set call ;
63 SYMBOL: post-refresh-get?
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 [
75 [ ] t register-callback forward-to-id
76 ] callcc1 restore-request
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* ;
91 : show-final ( quot -- * )
92 [ redirect-to-here store-current-show ] dip
93 call exit-with ; inline
95 : resuming-callback ( responder request -- id )
96 url>> cont-id query-param swap callbacks>> at ;
98 M: callback-responder call-responder* ( path responder -- response )
102 [ callback-responder set ]
103 [ request get resuming-callback ] bi
108 callback-responder get responder>> call-responder
110 ] with-exit-continuation ;
112 : show-page ( quot -- )
113 [ redirect-to-here store-current-show ] dip
115 [ ] t register-callback swap call exit-with
116 ] callcc1 restore-request ; inline
118 : quot-id ( quot -- id )
119 current-show get swap t register-callback ;
121 : quot-url ( quot -- url )
122 quot-id f swap cont-id associate derive-url ;