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
5 continuations fry calendar combinators combinators.short-circuit
6 destructors alarms io.sockets db db.tuples db.types
7 http http.server http.server.dispatchers http.server.filters
8 furnace.cache furnace.scopes furnace.utilities ;
11 TUPLE: session < scope user-agent client ;
13 : <session> ( id -- session )
14 session new-server-state ;
18 { "user-agent" "USER_AGENT" TEXT +not-null+ }
19 { "client" "CLIENT" TEXT +not-null+ }
22 : get-session ( id -- session )
23 dup [ session get-state ] when ;
25 GENERIC: init-session* ( responder -- )
27 M: object init-session* drop ;
29 M: dispatcher init-session* default>> init-session* ;
31 M: filter-responder init-session* responder>> init-session* ;
33 TUPLE: sessions < server-state-manager domain verify? ;
35 : <sessions> ( responder -- responder' )
36 sessions new-server-state-manager
39 : session-changed ( -- )
40 session get scope-changed ;
42 : sget ( key -- value ) session get scope-get ;
44 : sset ( value key -- ) session get scope-set ;
46 : schange ( key quot -- ) session get scope-change ; inline
48 : init-session ( session -- )
49 session [ sessions get init-session* ] with-variable ;
51 : touch-session ( session -- )
52 sessions get touch-state ;
54 : remote-host ( -- string )
56 [ request get "x-forwarded-for" header ]
57 [ remote-address get host>> ]
60 : empty-session ( -- session )
63 user-agent >>user-agent
66 : begin-session ( -- session )
67 empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
69 : save-session-after ( session -- )
70 sessions get save-scope-after ;
72 : existing-session ( path session -- response )
73 [ session set ] [ save-session-after ] bi
74 sessions get responder>> call-responder ;
76 CONSTANT: session-id-key "__s"
78 : verify-session ( session -- session )
79 sessions get verify?>> [
82 [ client>> remote-host = ]
83 [ user-agent>> user-agent = ]
84 bi and [ drop f ] unless
88 : request-session ( -- session/f )
90 client-state dup string? [ string>number ] when
91 get-session verify-session ;
93 : <session-cookie> ( -- cookie )
94 session get id>> session-id-key <cookie>
95 "$sessions" resolve-base-path >>path
96 sessions get domain>> >>domain ;
98 : put-session-cookie ( response -- response' )
99 <session-cookie> put-cookie ;
101 M: sessions modify-form ( responder -- )
102 drop session get id>> session-id-key hidden-form-field ;
104 M: sessions call-responder* ( path responder -- response )
106 request-session [ begin-session ] unless*
107 existing-session put-session-cookie ;
111 : check-session ( state/f -- state/f )
112 dup [ dup session>> session get id>> = [ drop f ] unless ] when ;