1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: namespaces assocs kernel sequences accessors hashtables
4 urls db.types db.tuples math.parser fry logging combinators
5 html.templates.chloe.syntax
6 http http.server http.server.filters http.server.redirection
12 IN: furnace.conversations
14 TUPLE: conversation < scope
16 method url post-data ;
18 : <conversation> ( id -- aside )
19 conversation new-server-state ;
21 conversation "CONVERSATIONS" {
22 { "session" "SESSION" BIG-INTEGER +not-null+ }
23 { "method" "METHOD" { VARCHAR 10 } }
25 { "post-data" "POST_DATA" FACTOR-BLOB }
28 : conversation-id-key "__c" ;
30 TUPLE: conversations < server-state-manager ;
32 : <conversations> ( responder -- responder' )
33 conversations new-server-state-manager ;
37 SYMBOL: conversation-id
39 : cget ( key -- value )
40 conversation get scope-get ;
42 : cset ( value key -- )
43 conversation get scope-set ;
45 : cchange ( key quot -- )
46 conversation get scope-change ; inline
48 : get-conversation ( id -- conversation )
49 dup [ conversation get-state ] when
50 dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
52 : request-conversation-id ( request -- id )
53 conversation-id-key swap request-params at string>number ;
55 : request-conversation ( request -- conversation )
56 request-conversation-id get-conversation ;
58 : save-conversation-after ( conversation -- )
59 conversations get save-scope-after ;
61 : set-conversation ( conversation -- )
64 [ id>> conversation-id set ]
65 [ save-conversation-after ]
69 : init-conversations ( conversations -- )
71 request get request-conversation-id
75 M: conversations call-responder*
76 [ init-conversations ]
81 : empty-conversastion ( -- conversation )
82 conversation empty-scope
83 session get id>> >>session ;
85 : touch-conversation ( conversation -- )
86 conversations get touch-state ;
88 : add-conversation ( conversation -- )
89 [ touch-conversation ] [ insert-tuple ] bi ;
91 : begin-conversation* ( -- conversation )
92 empty-conversastion dup add-conversation ;
94 : begin-conversation ( -- )
100 : end-conversation ( -- )
102 conversation-id off ;
104 : <conversation-redirect> ( url seq -- response )
106 [ [ get ] keep cset ] each
109 : restore-conversation ( seq -- )
110 conversation get dup [
112 [ '[ , key? ] filter ]
113 [ '[ [ , at ] keep set ] each ]
121 [ method>> >>method ]
123 [ post-data>> >>post-data ]
127 : end-aside-post ( aside -- response )
130 over post-data>> >>post-data
133 url>> path>> split-path
134 conversations get responder>> call-responder ;
136 \ end-aside-post DEBUG add-input-logging
138 ERROR: end-aside-in-get-error ;
140 : move-on ( id -- response )
141 post-request? [ end-aside-in-get-error ] unless
143 { "GET" [ url>> <redirect> ] }
144 { "HEAD" [ url>> <redirect> ] }
145 { "POST" [ end-aside-post ] }
148 : get-aside ( id -- conversation )
149 get-conversation dup [ dup method>> [ drop f ] unless ] when ;
151 : end-aside* ( url id -- response )
152 get-aside [ move-on ] [ <redirect> ] ?if ;
154 : end-aside ( default -- response )
159 M: conversations link-attr ( tag -- )
161 "aside" optional-attr {
162 { "none" [ conversation-id off ] }
163 { "begin" [ begin-aside ] }
168 M: conversations modify-query ( query conversations -- query' )
170 conversation-id get [
171 conversation-id-key associate assoc-union
174 M: conversations modify-form ( conversations -- )