132 lines
3.5 KiB
Factor
Executable File
132 lines
3.5 KiB
Factor
Executable File
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: assocs kernel math.intervals math.parser namespaces
|
|
strings random accessors quotations hashtables sequences continuations
|
|
fry calendar combinators combinators.lib destructors alarms
|
|
io.servers.connection
|
|
db db.tuples db.types
|
|
http http.server http.server.dispatchers http.server.filters
|
|
html.elements
|
|
furnace furnace.cache combinators.short-circuit ;
|
|
IN: furnace.sessions
|
|
|
|
TUPLE: session < server-state namespace user-agent client changed? ;
|
|
|
|
: <session> ( id -- session )
|
|
session new-server-state ;
|
|
|
|
session "SESSIONS"
|
|
{
|
|
{ "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
|
|
{ "user-agent" "USER_AGENT" TEXT +not-null+ }
|
|
{ "client" "CLIENT" TEXT +not-null+ }
|
|
} define-persistent
|
|
|
|
: get-session ( id -- session )
|
|
dup [ session get-state ] when ;
|
|
|
|
GENERIC: init-session* ( responder -- )
|
|
|
|
M: object init-session* drop ;
|
|
|
|
M: dispatcher init-session* default>> init-session* ;
|
|
|
|
M: filter-responder init-session* responder>> init-session* ;
|
|
|
|
TUPLE: sessions < server-state-manager domain verify? ;
|
|
|
|
: <sessions> ( responder -- responder' )
|
|
sessions new-server-state-manager
|
|
t >>verify? ;
|
|
|
|
: (session-changed) ( session -- )
|
|
t >>changed? drop ;
|
|
|
|
: session-changed ( -- )
|
|
session get (session-changed) ;
|
|
|
|
: sget ( key -- value )
|
|
session get namespace>> at ;
|
|
|
|
: sset ( value key -- )
|
|
session get
|
|
[ namespace>> set-at ] [ (session-changed) ] bi ;
|
|
|
|
: schange ( key quot -- )
|
|
session get
|
|
[ namespace>> swap change-at ] keep
|
|
(session-changed) ; inline
|
|
|
|
: init-session ( session -- )
|
|
session [ sessions get init-session* ] with-variable ;
|
|
|
|
: touch-session ( session -- )
|
|
sessions get touch-state ;
|
|
|
|
: remote-host ( -- string )
|
|
{
|
|
[ request get "x-forwarded-for" header ]
|
|
[ remote-address get host>> ]
|
|
} 0|| ;
|
|
|
|
: empty-session ( -- session )
|
|
f <session>
|
|
H{ } clone >>namespace
|
|
remote-host >>client
|
|
user-agent >>user-agent
|
|
dup touch-session ;
|
|
|
|
: begin-session ( -- session )
|
|
empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
|
|
|
|
! Destructor
|
|
TUPLE: session-saver session ;
|
|
|
|
C: <session-saver> session-saver
|
|
|
|
M: session-saver dispose
|
|
session>> dup changed?>> [
|
|
[ touch-session ] [ update-tuple ] bi
|
|
] [ drop ] if ;
|
|
|
|
: save-session-after ( session -- )
|
|
<session-saver> &dispose drop ;
|
|
|
|
: existing-session ( path session -- response )
|
|
[ session set ] [ save-session-after ] bi
|
|
sessions get responder>> call-responder ;
|
|
|
|
: session-id-key "__s" ;
|
|
|
|
: verify-session ( session -- session )
|
|
sessions get verify?>> [
|
|
dup [
|
|
dup
|
|
[ client>> remote-host = ]
|
|
[ user-agent>> user-agent = ]
|
|
bi and [ drop f ] unless
|
|
] when
|
|
] when ;
|
|
|
|
: request-session ( -- session/f )
|
|
session-id-key
|
|
client-state dup string? [ string>number ] when
|
|
get-session verify-session ;
|
|
|
|
: <session-cookie> ( -- cookie )
|
|
session get id>> session-id-key <cookie>
|
|
"$sessions" resolve-base-path >>path
|
|
sessions get timeout>> from-now >>expires
|
|
sessions get domain>> >>domain ;
|
|
|
|
: put-session-cookie ( response -- response' )
|
|
<session-cookie> put-cookie ;
|
|
|
|
M: sessions modify-form ( responder -- )
|
|
drop session get id>> session-id-key hidden-form-field ;
|
|
|
|
M: sessions call-responder* ( path responder -- response )
|
|
sessions set
|
|
request-session [ begin-session ] unless*
|
|
existing-session put-session-cookie ;
|