134 lines
3.5 KiB
Factor
Executable File
134 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.parser namespaces random
|
|
accessors quotations hashtables sequences continuations
|
|
fry calendar combinators destructors
|
|
http
|
|
http.server
|
|
http.server.sessions.storage
|
|
http.server.sessions.storage.null
|
|
html.elements ;
|
|
IN: http.server.sessions
|
|
|
|
TUPLE: session id expires namespace changed? ;
|
|
|
|
: <session> ( id -- session )
|
|
session new
|
|
swap >>id ;
|
|
|
|
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: session-manager < filter-responder sessions timeout domain ;
|
|
|
|
: <session-manager> ( responder -- responder' )
|
|
session-manager new
|
|
swap >>responder
|
|
null-sessions >>sessions
|
|
20 minutes >>timeout ;
|
|
|
|
: (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 managed -- )
|
|
>r session r> '[ , init-session* ] with-variable ;
|
|
|
|
: cutoff-time ( -- time )
|
|
session-manager get timeout>> from-now timestamp>millis ;
|
|
|
|
: touch-session ( session -- )
|
|
cutoff-time >>expires drop ;
|
|
|
|
: empty-session ( -- session )
|
|
f <session>
|
|
H{ } clone >>namespace
|
|
dup touch-session ;
|
|
|
|
: begin-session ( responder -- session )
|
|
>r empty-session r>
|
|
[ init-session ]
|
|
[ sessions>> new-session ]
|
|
[ drop ]
|
|
2tri ;
|
|
|
|
! Destructor
|
|
TUPLE: session-saver manager session ;
|
|
|
|
C: <session-saver> session-saver
|
|
|
|
M: session-saver dispose
|
|
[ session>> ] [ manager>> sessions>> ] bi
|
|
over changed?>> [
|
|
[ drop touch-session ] [ update-session ] 2bi
|
|
] [ 2drop ] if ;
|
|
|
|
: save-session-after ( manager session -- )
|
|
<session-saver> add-always-destructor ;
|
|
|
|
: existing-session ( path manager session -- response )
|
|
[ nip session set ]
|
|
[ save-session-after ]
|
|
[ drop responder>> ] 2tri
|
|
call-responder ;
|
|
|
|
: session-id-key "factorsessid" ;
|
|
|
|
: cookie-session-id ( -- id/f )
|
|
request get session-id-key get-cookie
|
|
dup [ value>> string>number ] when ;
|
|
|
|
: post-session-id ( -- id/f )
|
|
session-id-key request get post-data>> at string>number ;
|
|
|
|
: request-session-id ( -- id/f )
|
|
request get method>> {
|
|
{ "GET" [ cookie-session-id ] }
|
|
{ "HEAD" [ cookie-session-id ] }
|
|
{ "POST" [ post-session-id ] }
|
|
} case ;
|
|
|
|
: request-session ( responder -- session/f )
|
|
>r request-session-id r> sessions>> get-session ;
|
|
|
|
: <session-cookie> ( id -- cookie )
|
|
session-id-key <cookie>
|
|
"$session-manager" resolve-base-path >>path
|
|
session-manager get timeout>> from-now >>expires
|
|
session-manager get domain>> >>domain ;
|
|
|
|
: put-session-cookie ( response -- response' )
|
|
session get id>> number>string <session-cookie> put-cookie ;
|
|
|
|
: session-form-field ( -- )
|
|
<input
|
|
"hidden" =type
|
|
session-id-key =name
|
|
session get id>> number>string =value
|
|
input/> ;
|
|
|
|
M: session-manager call-responder* ( path responder -- response )
|
|
[ session-form-field ] add-form-hook
|
|
dup session-manager set
|
|
dup request-session [ dup begin-session ] unless*
|
|
existing-session put-session-cookie ;
|