1 ! Copyright (C) 2008, 2010 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
13 TUPLE: aside < server-state
14 session method url post-data ;
16 : <aside> ( id -- aside )
17 aside new-server-state ;
20 { "session" "SESSION" BIG-INTEGER +not-null+ }
21 { "method" "METHOD" { VARCHAR 10 } }
23 { "post-data" "POST_DATA" FACTOR-BLOB }
26 CONSTANT: aside-id-key "__a"
28 TUPLE: asides < server-state-manager ;
30 : <asides> ( responder -- responder' )
31 asides new-server-state-manager ;
35 : get-aside ( id -- aside )
36 dup [ aside get-state ] when check-session ;
38 : request-aside-id ( request -- id )
39 aside-id-key swap request-params at string>number ;
41 : request-aside ( request -- aside )
42 request-aside-id get-aside ;
44 : set-aside ( aside -- )
45 [ id>> aside-id set ] when* ;
47 : init-asides ( asides -- )
49 request get request-aside
52 M: asides call-responder*
53 [ init-asides ] [ call-next-method ] bi ;
55 : touch-aside ( aside -- )
56 asides get touch-state ;
58 : begin-aside ( url -- )
61 session get id>> >>session
62 request get method>> >>method
63 request get post-data>> >>post-data
64 [ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
66 : end-aside-post ( aside -- response )
69 over post-data>> >>post-data
72 [ [ post-data>> params>> params set ] [ url>> url set ] bi ]
73 [ url>> path>> split-path asides get responder>> call-responder ] bi ;
75 \ end-aside-post DEBUG add-input-logging
77 ERROR: end-aside-in-get-error ;
79 : move-on ( id -- response )
80 post-request? [ throw-end-aside-in-get-error ] unless
82 { "GET" [ url>> <redirect> ] }
83 { "HEAD" [ url>> <redirect> ] }
84 { "POST" [ end-aside-post ] }
87 : end-aside ( default -- response )
88 aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
90 M: asides link-attr ( tag responder -- )
92 "aside" optional-attr {
93 { "none" [ aside-id off ] }
94 { "begin" [ url get begin-aside ] }
99 M: asides modify-query ( query asides -- query' )
102 aside-id-key associate assoc-union
105 M: asides modify-form ( asides -- xml/f )