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