steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Clean up session persistence

db4
Slava Pestov 2008-04-26 01:44:45 -05:00
parent 30ef9dbc77
commit ca77a729d8
8 changed files with 235 additions and 239 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
extra/http/http-tests.factor
View File

@ -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

123
extra/http/server/sessions/sessions-tests.factor
View File

@ -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

100
extra/http/server/sessions/sessions.factor
View File

@ -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* ;

37
extra/http/server/sessions/storage/assoc/assoc.factor
View File

@ -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 ;

24
extra/http/server/sessions/storage/db/db-tests.factor
View File

@ -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

41
extra/http/server/sessions/storage/db/db.factor
View File

@ -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 ;

16
extra/http/server/sessions/storage/null/null.factor Normal file
View File

@ -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 ;

6
extra/http/server/sessions/storage/storage.factor
View File

@ -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 -- )