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.short-circuit destructors alarms
8 http http.server http.server.dispatchers http.server.filters
10 furnace furnace.cache furnace.scopes ;
13 TUPLE: session < scope user-agent client ;
15 : <session> ( id -- session )
16 session new-server-state ;
20 { "user-agent" "USER_AGENT" TEXT +not-null+ }
21 { "client" "CLIENT" TEXT +not-null+ }
24 : get-session ( id -- session )
25 dup [ session get-state ] when ;
27 GENERIC: init-session* ( responder -- )
29 M: object init-session* drop ;
31 M: dispatcher init-session* default>> init-session* ;
33 M: filter-responder init-session* responder>> init-session* ;
35 TUPLE: sessions < server-state-manager domain verify? ;
37 : <sessions> ( responder -- responder' )
38 sessions new-server-state-manager
41 : session-changed ( -- )
42 session get scope-changed ;
44 : sget ( key -- value ) session get scope-get ;
46 : sset ( value key -- ) session get scope-set ;
48 : schange ( key quot -- ) session get scope-change ; inline
50 : init-session ( session -- )
51 session [ sessions get init-session* ] with-variable ;
53 : touch-session ( session -- )
54 sessions get touch-state ;
56 : remote-host ( -- string )
58 [ request get "x-forwarded-for" header ]
59 [ remote-address get host>> ]
62 : empty-session ( -- session )
65 user-agent >>user-agent
68 : begin-session ( -- session )
69 empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
71 : save-session-after ( session -- )
72 sessions get save-scope-after ;
74 : existing-session ( path session -- response )
75 [ session set ] [ save-session-after ] bi
76 sessions get responder>> call-responder ;
78 : session-id-key "__s" ;
80 : verify-session ( session -- session )
81 sessions get verify?>> [
84 [ client>> remote-host = ]
85 [ user-agent>> user-agent = ]
86 bi and [ drop f ] unless
90 : request-session ( -- session/f )
92 client-state dup string? [ string>number ] when
93 get-session verify-session ;
95 : <session-cookie> ( -- cookie )
96 session get id>> session-id-key <cookie>
97 "$sessions" resolve-base-path >>path
98 sessions get domain>> >>domain ;
100 : put-session-cookie ( response -- response' )
101 <session-cookie> put-cookie ;
103 M: sessions modify-form ( responder -- )
104 drop session get id>> session-id-key hidden-form-field ;
106 M: sessions call-responder* ( path responder -- response )
108 request-session [ begin-session ] unless*
109 existing-session put-session-cookie ;