1 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: assocs kernel math.intervals math.parser namespaces
4 strings random accessors quotations hashtables sequences continuations
5 fry calendar combinators combinators.lib destructors alarms
8 http http.server http.server.dispatchers http.server.filters
10 furnace furnace.cache combinators.short-circuit ;
13 TUPLE: session < server-state namespace user-agent client changed? ;
15 : <session> ( id -- session )
16 session new-server-state ;
20 { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
21 { "user-agent" "USER_AGENT" TEXT +not-null+ }
22 { "client" "CLIENT" TEXT +not-null+ }
25 : get-session ( id -- session )
26 dup [ session get-state ] when ;
28 GENERIC: init-session* ( responder -- )
30 M: object init-session* drop ;
32 M: dispatcher init-session* default>> init-session* ;
34 M: filter-responder init-session* responder>> init-session* ;
36 TUPLE: sessions < server-state-manager domain verify? ;
38 : <sessions> ( responder -- responder' )
39 sessions new-server-state-manager
42 : (session-changed) ( session -- )
45 : session-changed ( -- )
46 session get (session-changed) ;
48 : sget ( key -- value )
49 session get namespace>> at ;
51 : sset ( value key -- )
53 [ namespace>> set-at ] [ (session-changed) ] bi ;
55 : schange ( key quot -- )
57 [ namespace>> swap change-at ] keep
58 (session-changed) ; inline
60 : init-session ( session -- )
61 session [ sessions get init-session* ] with-variable ;
63 : touch-session ( session -- )
64 sessions get touch-state ;
66 : remote-host ( -- string )
68 [ request get "x-forwarded-for" header ]
69 [ remote-address get host>> ]
72 : empty-session ( -- session )
74 H{ } clone >>namespace
76 user-agent >>user-agent
79 : begin-session ( -- session )
80 empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
83 TUPLE: session-saver session ;
85 C: <session-saver> session-saver
87 M: session-saver dispose
88 session>> dup changed?>> [
89 [ touch-session ] [ update-tuple ] bi
92 : save-session-after ( session -- )
93 <session-saver> &dispose drop ;
95 : existing-session ( path session -- response )
96 [ session set ] [ save-session-after ] bi
97 sessions get responder>> call-responder ;
99 : session-id-key "__s" ;
101 : verify-session ( session -- session )
102 sessions get verify?>> [
105 [ client>> remote-host = ]
106 [ user-agent>> user-agent = ]
107 bi and [ drop f ] unless
111 : request-session ( -- session/f )
113 client-state dup string? [ string>number ] when
114 get-session verify-session ;
116 : <session-cookie> ( -- cookie )
117 session get id>> session-id-key <cookie>
118 "$sessions" resolve-base-path >>path
119 sessions get domain>> >>domain ;
121 : put-session-cookie ( response -- response' )
122 <session-cookie> put-cookie ;
124 M: sessions modify-form ( responder -- )
125 drop session get id>> session-id-key hidden-form-field ;
127 M: sessions call-responder* ( path responder -- response )
129 request-session [ begin-session ] unless*
130 existing-session put-session-cookie ;