Clean up session persistence
Slava Pestov
parent
30ef9dbc77
commit
ca77a729d8
|
|
@ -1,6 +1,6 @@
|
|||
USING: http tools.test multiline tuple-syntax
|
||||
io.streams.string kernel arrays splitting sequences
|
||||
assocs io.sockets ;
|
||||
assocs io.sockets db db.sqlite ;
|
||||
IN: http.tests
|
||||
|
||||
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
|
||||
|
|
@ -134,15 +134,22 @@ read-response-test-1' 1array [
|
|||
|
||||
! Live-fire exercise
|
||||
USING: http.server http.server.static http.server.sessions
|
||||
http.server.actions http.server.auth.login http.client
|
||||
io.server io.files io accessors namespaces threads
|
||||
io.encodings.ascii ;
|
||||
http.server.sessions.storage.db http.server.actions
|
||||
http.server.auth.login http.server.db http.client
|
||||
io.server io.files io io.encodings.ascii
|
||||
accessors namespaces threads ;
|
||||
|
||||
: add-quit-action
|
||||
<action>
|
||||
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
|
||||
"quit" add-responder ;
|
||||
|
||||
: test-db "test.db" temp-file sqlite-db ;
|
||||
|
||||
test-db [
|
||||
init-sessions-table
|
||||
] with-db
|
||||
|
||||
[ ] [
|
||||
[
|
||||
<dispatcher>
|
||||
|
|
@ -187,11 +194,14 @@ io.encodings.ascii ;
|
|||
<dispatcher>
|
||||
<action> <protected>
|
||||
<login>
|
||||
<url-sessions> "" add-responder
|
||||
<url-sessions>
|
||||
sessions-in-db >>sessions
|
||||
"" add-responder
|
||||
add-quit-action
|
||||
<dispatcher>
|
||||
<action> "a" add-main-responder
|
||||
"d" add-responder
|
||||
test-db <db-persistence>
|
||||
main-responder set
|
||||
|
||||
[ 1237 httpd ] "HTTPD test" spawn drop
|
||||
|
|
@ -214,9 +224,12 @@ io.encodings.ascii ;
|
|||
[
|
||||
<dispatcher>
|
||||
<action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
|
||||
<login> <url-sessions>
|
||||
<login>
|
||||
<url-sessions>
|
||||
sessions-in-db >>sessions
|
||||
"" add-responder
|
||||
add-quit-action
|
||||
test-db <db-persistence>
|
||||
main-responder set
|
||||
|
||||
[ 1237 httpd ] "HTTPD test" spawn drop
|
||||
|
|
|
|||
|
|
@ -1,12 +1,14 @@
|
|||
IN: http.server.sessions.tests
|
||||
USING: tools.test http http.server.sessions
|
||||
http.server.sessions.storage http.server.sessions.storage.assoc
|
||||
http.server.sessions.storage http.server.sessions.storage.db
|
||||
http.server.actions http.server math namespaces kernel accessors
|
||||
prettyprint io.streams.string splitting destructors sequences ;
|
||||
prettyprint io.streams.string io.files splitting destructors
|
||||
sequences db db.sqlite ;
|
||||
|
||||
[ H{ } ] [ H{ } add-session-id ] unit-test
|
||||
|
||||
: with-session \ session swap with-variable ; inline
|
||||
: with-session
|
||||
[
|
||||
>r [ save-session-after ] [ \ session set ] bi r> call
|
||||
] with-destructors ; inline
|
||||
|
||||
TUPLE: foo ;
|
||||
|
||||
|
|
@ -19,56 +21,6 @@ M: foo call-responder
|
|||
"x" [ 1+ ] schange
|
||||
"text/html" <content> [ "x" sget pprint ] >>body ;
|
||||
|
||||
[
|
||||
"123" session-id set
|
||||
H{ } clone session set
|
||||
session-changed? off
|
||||
|
||||
[ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test
|
||||
|
||||
[ ] [ 3 "x" sset ] unit-test
|
||||
|
||||
[ 9 ] [ "x" sget sq ] unit-test
|
||||
|
||||
[ ] [ "x" [ 1- ] schange ] unit-test
|
||||
|
||||
[ 4 ] [ "x" sget sq ] unit-test
|
||||
|
||||
[ t ] [ session-changed? get ] unit-test
|
||||
] with-scope
|
||||
|
||||
[ t ] [ f <url-sessions> url-sessions? ] unit-test
|
||||
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
|
||||
|
||||
[ ] [
|
||||
<foo> <url-sessions>
|
||||
<sessions-in-memory> >>sessions
|
||||
"manager" set
|
||||
] unit-test
|
||||
|
||||
[ { 5 0 } ] [
|
||||
[
|
||||
"manager" get begin-session drop
|
||||
dup "manager" get sessions>> get-session [ 5 "a" sset ] with-session
|
||||
dup "manager" get sessions>> get-session [ "a" sget , ] with-session
|
||||
dup "manager" get sessions>> get-session [ "x" sget , ] with-session
|
||||
"manager" get sessions>> get-session
|
||||
"manager" get sessions>> delete-session
|
||||
] { } make
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
<request>
|
||||
"GET" >>method
|
||||
request set
|
||||
{ "etc" } "manager" get call-responder
|
||||
response set
|
||||
] unit-test
|
||||
|
||||
[ 307 ] [ response get code>> ] unit-test
|
||||
|
||||
[ ] [ response get "location" header "=" split1 nip "id" set ] unit-test
|
||||
|
||||
: url-responder-mock-test
|
||||
[
|
||||
<request>
|
||||
|
|
@ -76,34 +28,10 @@ M: foo call-responder
|
|||
"id" get session-id-key set-query-param
|
||||
"/" >>path
|
||||
request set
|
||||
{ } "manager" get call-responder
|
||||
{ } session-manager get call-responder
|
||||
[ write-response-body drop ] with-string-writer
|
||||
] with-destructors ;
|
||||
|
||||
[ "1" ] [ url-responder-mock-test ] unit-test
|
||||
[ "2" ] [ url-responder-mock-test ] unit-test
|
||||
[ "3" ] [ url-responder-mock-test ] unit-test
|
||||
[ "4" ] [ url-responder-mock-test ] unit-test
|
||||
|
||||
[ ] [
|
||||
<foo> <cookie-sessions>
|
||||
<sessions-in-memory> >>sessions
|
||||
"manager" set
|
||||
] unit-test
|
||||
|
||||
[
|
||||
<request>
|
||||
"GET" >>method
|
||||
"/" >>path
|
||||
request set
|
||||
{ "etc" } "manager" get call-responder response set
|
||||
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
|
||||
response get
|
||||
] with-destructors
|
||||
response set
|
||||
|
||||
[ ] [ response get cookies>> "cookies" set ] unit-test
|
||||
|
||||
: cookie-responder-mock-test
|
||||
[
|
||||
<request>
|
||||
|
|
@ -111,35 +39,134 @@ response set
|
|||
"cookies" get >>cookies
|
||||
"/" >>path
|
||||
request set
|
||||
{ } "manager" get call-responder
|
||||
{ } session-manager get call-responder
|
||||
[ write-response-body drop ] with-string-writer
|
||||
] with-destructors ;
|
||||
|
||||
[ "2" ] [ cookie-responder-mock-test ] unit-test
|
||||
[ "3" ] [ cookie-responder-mock-test ] unit-test
|
||||
[ "4" ] [ cookie-responder-mock-test ] unit-test
|
||||
|
||||
: <exiting-action>
|
||||
<action>
|
||||
[
|
||||
"text/plain" <content> exit-with
|
||||
] >>display ;
|
||||
|
||||
[
|
||||
[ ] [
|
||||
<request>
|
||||
"GET" >>method
|
||||
"id" get session-id-key set-query-param
|
||||
"/" >>path
|
||||
request set
|
||||
"auth-test.db" temp-file sqlite-db [
|
||||
|
||||
[
|
||||
{ } <exiting-action> <cookie-sessions>
|
||||
call-responder
|
||||
] with-destructors response set
|
||||
[
|
||||
empty-session
|
||||
123 >>id session set
|
||||
session-changed? off
|
||||
|
||||
[ H{ { "factorsessid" 123 } } ] [ H{ } add-session-id ] unit-test
|
||||
|
||||
[ ] [ 3 "x" sset ] unit-test
|
||||
|
||||
[ 9 ] [ "x" sget sq ] unit-test
|
||||
|
||||
[ ] [ "x" [ 1- ] schange ] unit-test
|
||||
|
||||
[ 4 ] [ "x" sget sq ] unit-test
|
||||
|
||||
[ t ] [ session-changed? get ] unit-test
|
||||
] with-scope
|
||||
|
||||
[ t ] [ f <url-sessions> url-sessions? ] unit-test
|
||||
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
|
||||
|
||||
[ ] [
|
||||
<foo> <url-sessions>
|
||||
sessions-in-db >>sessions
|
||||
session-manager set
|
||||
] unit-test
|
||||
|
||||
[ "text/plain" ] [ response get "content-type" header ] unit-test
|
||||
[ t ] [
|
||||
session-manager get begin-session id>>
|
||||
session-manager get sessions>> get-session session?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ response get cookies>> empty? ] unit-test
|
||||
] with-scope
|
||||
[ { 5 0 } ] [
|
||||
[
|
||||
session-manager get begin-session
|
||||
dup [ 5 "a" sset ] with-session
|
||||
dup [ "a" sget , ] with-session
|
||||
dup [ "x" sget , ] with-session
|
||||
id>> session-manager get sessions>> delete-session
|
||||
] { } make
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
session-manager get begin-session id>>
|
||||
session-manager get sessions>> get-session [ "x" sget ] with-session
|
||||
] unit-test
|
||||
|
||||
[ { 5 0 } ] [
|
||||
[
|
||||
session-manager get begin-session id>>
|
||||
dup session-manager get sessions>> get-session [ 5 "a" sset ] with-session
|
||||
dup session-manager get sessions>> get-session [ "a" sget , ] with-session
|
||||
dup session-manager get sessions>> get-session [ "x" sget , ] with-session
|
||||
session-manager get sessions>> delete-session
|
||||
] { } make
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
<request>
|
||||
"GET" >>method
|
||||
request set
|
||||
{ "etc" } session-manager get call-responder
|
||||
] with-destructors
|
||||
response set
|
||||
] unit-test
|
||||
|
||||
[ 307 ] [ response get code>> ] unit-test
|
||||
|
||||
[ ] [ response get "location" header "=" split1 nip "id" set ] unit-test
|
||||
|
||||
[ "1" ] [ url-responder-mock-test ] unit-test
|
||||
[ "2" ] [ url-responder-mock-test ] unit-test
|
||||
[ "3" ] [ url-responder-mock-test ] unit-test
|
||||
[ "4" ] [ url-responder-mock-test ] unit-test
|
||||
|
||||
[ ] [
|
||||
<foo> <cookie-sessions>
|
||||
sessions-in-db >>sessions
|
||||
session-manager set
|
||||
] unit-test
|
||||
|
||||
[
|
||||
<request>
|
||||
"GET" >>method
|
||||
"/" >>path
|
||||
request set
|
||||
{ "etc" } session-manager get call-responder response set
|
||||
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
|
||||
response get
|
||||
] with-destructors
|
||||
response set
|
||||
|
||||
[ ] [ response get cookies>> "cookies" set ] unit-test
|
||||
|
||||
[ "2" ] [ cookie-responder-mock-test ] unit-test
|
||||
[ "3" ] [ cookie-responder-mock-test ] unit-test
|
||||
[ "4" ] [ cookie-responder-mock-test ] unit-test
|
||||
|
||||
[
|
||||
[ ] [
|
||||
<request>
|
||||
"GET" >>method
|
||||
"id" get session-id-key set-query-param
|
||||
"/" >>path
|
||||
request set
|
||||
|
||||
[
|
||||
{ } <exiting-action> <cookie-sessions>
|
||||
sessions-in-db >>sessions
|
||||
call-responder
|
||||
] with-destructors response set
|
||||
] unit-test
|
||||
|
||||
[ "text/plain" ] [ response get "content-type" header ] unit-test
|
||||
|
||||
[ f ] [ response get cookies>> empty? ] unit-test
|
||||
] with-scope
|
||||
] with-db
|
||||
|
|
|
|||
|
|
@ -1,16 +1,25 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs calendar kernel math.parser namespaces random
|
||||
accessors http http.server
|
||||
http.server.sessions.storage http.server.sessions.storage.assoc
|
||||
quotations hashtables sequences fry html.elements symbols
|
||||
continuations destructors ;
|
||||
USING: assocs kernel math.parser namespaces random
|
||||
accessors quotations hashtables sequences continuations
|
||||
fry calendar destructors
|
||||
http
|
||||
http.server
|
||||
http.server.sessions.storage
|
||||
http.server.sessions.storage.null
|
||||
html.elements ;
|
||||
IN: http.server.sessions
|
||||
|
||||
! ! ! ! ! !
|
||||
! WARNING: this session manager is vulnerable to XSRF attacks
|
||||
! ! ! ! ! !
|
||||
|
||||
TUPLE: session id user-agent client-addr namespace ;
|
||||
|
||||
: <session> ( id -- session )
|
||||
session new
|
||||
swap >>id ;
|
||||
|
||||
GENERIC: init-session* ( responder -- )
|
||||
|
||||
M: object init-session* drop ;
|
||||
|
|
@ -19,59 +28,65 @@ TUPLE: session-manager responder sessions ;
|
|||
|
||||
: new-session-manager ( responder class -- responder' )
|
||||
new
|
||||
<sessions-in-memory> >>sessions
|
||||
null-sessions >>sessions
|
||||
swap >>responder ; inline
|
||||
|
||||
SYMBOLS: session session-id session-changed? ;
|
||||
SYMBOL: session-changed?
|
||||
|
||||
: sget ( key -- value )
|
||||
session get at ;
|
||||
session get namespace>> at ;
|
||||
|
||||
: sset ( value key -- )
|
||||
session get set-at
|
||||
session get namespace>> set-at
|
||||
session-changed? on ;
|
||||
|
||||
: schange ( key quot -- )
|
||||
session get swap change-at
|
||||
session get namespace>> swap change-at
|
||||
session-changed? on ; inline
|
||||
|
||||
: sessions session-manager get sessions>> ;
|
||||
|
||||
: managed-responder session-manager get responder>> ;
|
||||
|
||||
: init-session ( managed -- session )
|
||||
H{ } clone [ session [ init-session* ] with-variable ] keep ;
|
||||
: init-session ( session managed -- )
|
||||
>r session r> '[ , init-session* ] with-variable ;
|
||||
|
||||
: begin-session ( responder -- id session )
|
||||
[ responder>> init-session ] [ sessions>> ] bi
|
||||
[ new-session ] [ drop ] 2bi ;
|
||||
: empty-session ( -- session )
|
||||
f <session>
|
||||
"" >>user-agent
|
||||
"" >>client-addr
|
||||
H{ } clone >>namespace ;
|
||||
|
||||
: begin-session ( responder -- session )
|
||||
>r empty-session r>
|
||||
[ responder>> init-session ]
|
||||
[ sessions>> new-session ]
|
||||
[ drop ]
|
||||
2tri ;
|
||||
|
||||
! Destructor
|
||||
TUPLE: session-saver id session ;
|
||||
TUPLE: session-saver session ;
|
||||
|
||||
C: <session-saver> session-saver
|
||||
|
||||
M: session-saver dispose
|
||||
session-changed? get [
|
||||
[ session>> ] [ id>> ] bi
|
||||
sessions update-session
|
||||
] [ drop ] if ;
|
||||
session-changed? get
|
||||
[ session>> sessions update-session ] [ drop ] if ;
|
||||
|
||||
: save-session-after ( id session -- )
|
||||
: save-session-after ( session -- )
|
||||
<session-saver> add-always-destructor ;
|
||||
|
||||
: call-responder/session ( path responder id session -- response )
|
||||
[ save-session-after ]
|
||||
[ [ session-id set ] [ session set ] bi* ] 2bi
|
||||
: call-responder/session ( path responder session -- response )
|
||||
[ save-session-after ] [ session set ] bi
|
||||
[ session-manager set ] [ responder>> call-responder ] bi ;
|
||||
|
||||
TUPLE: null-sessions < session-manager ;
|
||||
|
||||
: <null-sessions>
|
||||
: <null-sessions> ( responder -- manager )
|
||||
null-sessions new-session-manager ;
|
||||
|
||||
M: null-sessions call-responder ( path responder -- response )
|
||||
H{ } clone f call-responder/session ;
|
||||
<session> call-responder/session ;
|
||||
|
||||
TUPLE: url-sessions < session-manager ;
|
||||
|
||||
|
|
@ -80,42 +95,43 @@ TUPLE: url-sessions < session-manager ;
|
|||
|
||||
: session-id-key "factorsessid" ;
|
||||
|
||||
: current-url-session ( responder -- id/f session/f )
|
||||
[ request-params session-id-key swap at ] [ sessions>> ] bi*
|
||||
[ drop ] [ get-session ] 2bi ;
|
||||
: current-url-session ( responder -- session/f )
|
||||
>r request-params session-id-key swap at string>number
|
||||
r> sessions>> get-session ;
|
||||
|
||||
: add-session-id ( query -- query' )
|
||||
session-id get [ session-id-key associate assoc-union ] when* ;
|
||||
session get [ id>> session-id-key associate assoc-union ] when* ;
|
||||
|
||||
: session-form-field ( -- )
|
||||
<input
|
||||
"hidden" =type
|
||||
session-id-key =id
|
||||
session-id-key =name
|
||||
session-id get =value
|
||||
session get id>> =value
|
||||
input/> ;
|
||||
|
||||
: new-url-session ( responder -- response )
|
||||
[ f ] [ begin-session drop session-id-key associate ] bi*
|
||||
: new-url-session ( path responder -- response )
|
||||
[ drop f ] [ begin-session id>> session-id-key associate ] bi*
|
||||
<temporary-redirect> ;
|
||||
|
||||
M: url-sessions call-responder ( path responder -- response )
|
||||
[ add-session-id ] link-hook set
|
||||
[ session-form-field ] form-hook set
|
||||
dup current-url-session dup [
|
||||
dup current-url-session [
|
||||
call-responder/session
|
||||
] [
|
||||
2drop nip new-url-session
|
||||
] if ;
|
||||
new-url-session
|
||||
] if* ;
|
||||
|
||||
TUPLE: cookie-sessions < session-manager ;
|
||||
|
||||
: <cookie-sessions> ( responder -- responder' )
|
||||
cookie-sessions new-session-manager ;
|
||||
|
||||
: current-cookie-session ( responder -- id namespace/f )
|
||||
: current-cookie-session ( responder -- session/f )
|
||||
request get session-id-key get-cookie dup
|
||||
[ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ;
|
||||
[ value>> string>number swap sessions>> get-session ]
|
||||
[ 2drop f ] if ;
|
||||
|
||||
: <session-cookie> ( id -- cookie )
|
||||
session-id-key <cookie> ;
|
||||
|
|
@ -123,12 +139,12 @@ TUPLE: cookie-sessions < session-manager ;
|
|||
: call-responder/new-session ( path responder -- response )
|
||||
dup begin-session
|
||||
[ call-responder/session ]
|
||||
[ drop <session-cookie> ] 2bi
|
||||
[ id>> number>string <session-cookie> ] bi
|
||||
put-cookie ;
|
||||
|
||||
M: cookie-sessions call-responder ( path responder -- response )
|
||||
dup current-cookie-session dup [
|
||||
dup current-cookie-session [
|
||||
call-responder/session
|
||||
] [
|
||||
2drop call-responder/new-session
|
||||
] if ;
|
||||
call-responder/new-session
|
||||
] if* ;
|
||||
|
|
|
|||
|
|
@ -1,37 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs assocs.lib accessors http.server.sessions.storage
|
||||
alarms kernel fry http.server ;
|
||||
IN: http.server.sessions.storage.assoc
|
||||
|
||||
TUPLE: sessions-in-memory sessions alarms ;
|
||||
|
||||
: <sessions-in-memory> ( -- storage )
|
||||
H{ } clone H{ } clone sessions-in-memory boa ;
|
||||
|
||||
: cancel-session-timeout ( id storage -- )
|
||||
alarms>> at [ cancel-alarm ] when* ;
|
||||
|
||||
: touch-session ( id storage -- )
|
||||
[ cancel-session-timeout ]
|
||||
[ '[ , , delete-session ] timeout later ]
|
||||
[ alarms>> set-at ]
|
||||
2tri ;
|
||||
|
||||
M: sessions-in-memory get-session ( id storage -- namespace )
|
||||
[ sessions>> at ] [ touch-session ] 2bi ;
|
||||
|
||||
M: sessions-in-memory update-session ( namespace id storage -- )
|
||||
[ sessions>> set-at ]
|
||||
[ touch-session ]
|
||||
2bi ;
|
||||
|
||||
M: sessions-in-memory delete-session ( id storage -- )
|
||||
[ sessions>> delete-at ]
|
||||
[ cancel-session-timeout ]
|
||||
2bi ;
|
||||
|
||||
M: sessions-in-memory new-session ( namespace storage -- id )
|
||||
[ sessions>> set-at-unique ]
|
||||
[ [ touch-session ] [ drop ] 2bi ]
|
||||
bi ;
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
IN: http.server.sessions.storage.db
|
||||
USING: http.server.sessions.storage
|
||||
http.server.sessions.storage.db namespaces io.files
|
||||
db.sqlite db accessors math tools.test kernel assocs
|
||||
sequences ;
|
||||
|
||||
sessions-in-db "storage" set
|
||||
|
||||
"auth-test.db" temp-file sqlite-db [
|
||||
[ ] [ init-sessions-table ] unit-test
|
||||
|
||||
[ f ] [ H{ } "storage" get new-session empty? ] unit-test
|
||||
|
||||
H{ } "storage" get new-session "id" set
|
||||
|
||||
"id" get "storage" get get-session "session" set
|
||||
"a" "b" "session" get set-at
|
||||
|
||||
"session" get "id" get "storage" get update-session
|
||||
|
||||
[ H{ { "b" "a" } } ] [
|
||||
"id" get "storage" get get-session
|
||||
] unit-test
|
||||
] with-db
|
||||
|
|
@ -1,46 +1,31 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs accessors http.server.sessions.storage
|
||||
alarms kernel http.server db.tuples db.types math.parser
|
||||
classes.singleton ;
|
||||
USING: assocs accessors kernel http.server.sessions.storage
|
||||
http.server.sessions http.server db.tuples db.types math.parser
|
||||
classes.singleton random ;
|
||||
IN: http.server.sessions.storage.db
|
||||
|
||||
SINGLETON: sessions-in-db
|
||||
|
||||
TUPLE: session id namespace ;
|
||||
|
||||
session "SESSIONS"
|
||||
{
|
||||
! { "id" "ID" +random-id+ system-random-generator }
|
||||
{ "id" "ID" INTEGER +native-id+ }
|
||||
{ "user-agent" "USERAGENT" { VARCHAR 256 } +not-null+ }
|
||||
{ "client-addr" "CLIENTADDR" { VARCHAR 256 } +not-null+ }
|
||||
{ "namespace" "NAMESPACE" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
: init-sessions-table session ensure-table ;
|
||||
|
||||
: <session> ( id -- session )
|
||||
session new
|
||||
swap dup [ string>number ] when >>id ;
|
||||
M: sessions-in-db get-session ( id storage -- session/f )
|
||||
drop dup [ <session> select-tuple ] when ;
|
||||
|
||||
M: sessions-in-db get-session ( id storage -- namespace/f )
|
||||
drop
|
||||
dup [
|
||||
<session>
|
||||
select-tuple dup [ namespace>> ] when
|
||||
] when ;
|
||||
|
||||
M: sessions-in-db update-session ( namespace id storage -- )
|
||||
drop
|
||||
<session>
|
||||
swap >>namespace
|
||||
update-tuple ;
|
||||
M: sessions-in-db update-session ( session storage -- )
|
||||
drop update-tuple ;
|
||||
|
||||
M: sessions-in-db delete-session ( id storage -- )
|
||||
drop
|
||||
<session>
|
||||
delete-tuple ;
|
||||
drop <session> delete-tuple ;
|
||||
|
||||
M: sessions-in-db new-session ( namespace storage -- id )
|
||||
drop
|
||||
f <session>
|
||||
swap >>namespace
|
||||
[ insert-tuple ] [ id>> number>string ] bi ;
|
||||
M: sessions-in-db new-session ( session storage -- )
|
||||
drop insert-tuple ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel http.server.sessions.storage ;
|
||||
IN: http.server.sessions.storage.null
|
||||
|
||||
SINGLETON: null-sessions
|
||||
|
||||
: null-sessions-error "No session storage installed" throw ;
|
||||
|
||||
M: null-sessions get-session null-sessions-error ;
|
||||
|
||||
M: null-sessions update-session null-sessions-error ;
|
||||
|
||||
M: null-sessions delete-session null-sessions-error ;
|
||||
|
||||
M: null-sessions new-session null-sessions-error ;
|
||||
|
|
@ -5,10 +5,10 @@ IN: http.server.sessions.storage
|
|||
|
||||
: timeout 20 minutes ;
|
||||
|
||||
GENERIC: get-session ( id storage -- namespace )
|
||||
GENERIC: get-session ( id storage -- session )
|
||||
|
||||
GENERIC: update-session ( namespace id storage -- )
|
||||
GENERIC: update-session ( session storage -- )
|
||||
|
||||
GENERIC: delete-session ( id storage -- )
|
||||
|
||||
GENERIC: new-session ( namespace storage -- id )
|
||||
GENERIC: new-session ( session storage -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue