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

Rename session-manager to sessions

db4
Slava Pestov 2008-04-29 05:58:34 -05:00
parent ee46527023
commit 453f55cc5d
6 changed files with 126 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -194,7 +194,7 @@ test-db [
<dispatcher> <dispatcher>
<action> <protected> <action> <protected>
<login> <login>
<session-manager> <sessions>
sessions-in-db >>sessions sessions-in-db >>sessions
"" add-responder "" add-responder
add-quit-action add-quit-action
@ -225,7 +225,7 @@ test-db [
<dispatcher> <dispatcher>
<action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display <action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
<login> <login>
<session-manager> <sessions>
sessions-in-db >>sessions sessions-in-db >>sessions
"" add-responder "" add-responder
add-quit-action add-quit-action

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

@ -1,16 +1,12 @@
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.db
http.server.actions http.server math namespaces kernel accessors http.server.actions http.server math namespaces kernel accessors
prettyprint io.streams.string io.files splitting destructors prettyprint io.streams.string io.files splitting destructors
sequences db db.sqlite continuations ; sequences db db.sqlite continuations ;
: with-session : with-session
[ [
>r >r [ save-session-after ] [ session set ] bi r> call
[ session-manager get swap save-session-after ]
[ \ session set ] bi
r> call
] with-destructors ; inline ] with-destructors ; inline
TUPLE: foo ; TUPLE: foo ;
@ -31,18 +27,18 @@ M: foo call-responder*
"id" get session-id-key set-query-param "id" get session-id-key set-query-param
"/" >>path "/" >>path
request set request set
{ } session-manager get call-responder { } sessions get call-responder
[ write-response-body drop ] with-string-writer [ write-response-body drop ] with-string-writer
] with-destructors ; ] with-destructors ;
: session-manager-mock-test : sessions-mock-test
[ [
<request> <request>
"GET" >>method "GET" >>method
"cookies" get >>cookies "cookies" get >>cookies
"/" >>path "/" >>path
request set request set
{ } session-manager get call-responder { } sessions get call-responder
[ write-response-body drop ] with-string-writer [ write-response-body drop ] with-string-writer
] with-destructors ; ] with-destructors ;
@ -60,14 +56,15 @@ M: foo call-responder*
init-sessions-table init-sessions-table
[ ] [ [ ] [
<foo> <session-manager> <foo> <sessions>
sessions-in-db >>sessions sessions set
session-manager set
] unit-test ] unit-test
[ [
[ ] [
empty-session empty-session
123 >>id session set 123 >>id session set
] unit-test
[ ] [ 3 "x" sset ] unit-test [ ] [ 3 "x" sset ] unit-test
@ -81,39 +78,38 @@ M: foo call-responder*
] with-scope ] with-scope
[ t ] [ [ t ] [
session-manager get begin-session id>> begin-session id>>
session-manager get sessions>> get-session session? get-session session?
] unit-test ] unit-test
[ { 5 0 } ] [ [ { 5 0 } ] [
[ [
session-manager get begin-session begin-session
dup [ 5 "a" sset ] with-session dup [ 5 "a" sset ] with-session
dup [ "a" sget , ] with-session dup [ "a" sget , ] with-session
dup [ "x" sget , ] with-session dup [ "x" sget , ] with-session
id>> session-manager get sessions>> delete-session drop
] { } make ] { } make
] unit-test ] unit-test
[ 0 ] [ [ 0 ] [
session-manager get begin-session id>> begin-session id>>
session-manager get sessions>> get-session [ "x" sget ] with-session get-session [ "x" sget ] with-session
] unit-test ] unit-test
[ { 5 0 } ] [ [ { 5 0 } ] [
[ [
session-manager get begin-session id>> begin-session id>>
dup session-manager get sessions>> get-session [ 5 "a" sset ] with-session dup get-session [ 5 "a" sset ] with-session
dup session-manager get sessions>> get-session [ "a" sget , ] with-session dup get-session [ "a" sget , ] with-session
dup session-manager get sessions>> get-session [ "x" sget , ] with-session dup get-session [ "x" sget , ] with-session
session-manager get sessions>> delete-session drop
] { } make ] { } make
] unit-test ] unit-test
[ ] [ [ ] [
<foo> <session-manager> <foo> <sessions>
sessions-in-db >>sessions sessions set
session-manager set
] unit-test ] unit-test
[ [
@ -121,7 +117,7 @@ M: foo call-responder*
"GET" >>method "GET" >>method
"/" >>path "/" >>path
request set request set
{ "etc" } session-manager get call-responder response set { "etc" } sessions 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
@ -129,9 +125,9 @@ M: foo call-responder*
[ ] [ response get cookies>> "cookies" set ] unit-test [ ] [ response get cookies>> "cookies" set ] unit-test
[ "2" ] [ session-manager-mock-test ] unit-test [ "2" ] [ sessions-mock-test ] unit-test
[ "3" ] [ session-manager-mock-test ] unit-test [ "3" ] [ sessions-mock-test ] unit-test
[ "4" ] [ session-manager-mock-test ] unit-test [ "4" ] [ sessions-mock-test ] unit-test
[ [
[ ] [ [ ] [
@ -142,8 +138,7 @@ M: foo call-responder*
request set request set
[ [
{ } <exiting-action> <session-manager> { } <exiting-action> <sessions>
sessions-in-db >>sessions
call-responder call-responder
] with-destructors response set ] with-destructors response set
] unit-test ] unit-test

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

@ -1,13 +1,10 @@
! 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 kernel math.parser namespaces random USING: assocs kernel math.intervals math.parser namespaces
accessors quotations hashtables sequences continuations random accessors quotations hashtables sequences continuations
fry calendar combinators destructors fry calendar combinators destructors alarms
http db db.tuples db.types
http.server http http.server html.elements ;
http.server.sessions.storage
http.server.sessions.storage.null
html.elements ;
IN: http.server.sessions IN: http.server.sessions
TUPLE: session id expires namespace changed? ; TUPLE: session id expires namespace changed? ;
@ -16,6 +13,28 @@ TUPLE: session id expires namespace changed? ;
session new session new
swap >>id ; swap >>id ;
session "SESSIONS"
{
{ "id" "ID" +random-id+ system-random-generator }
{ "expires" "EXPIRES" BIG-INTEGER +not-null+ }
{ "namespace" "NAMESPACE" FACTOR-BLOB }
} define-persistent
: get-session ( id -- session )
dup [ <session> select-tuple ] when ;
: init-sessions-table session ensure-table ;
: expired-sessions ( -- session )
f <session>
-1.0/0.0 now timestamp>millis [a,b] >>expires
select-tuples ;
: start-expiring-sessions ( db seq -- )
'[
, , [ expired-sessions [ delete-tuple ] each ] with-db
] 5 minutes every drop ;
GENERIC: init-session* ( responder -- ) GENERIC: init-session* ( responder -- )
M: object init-session* drop ; M: object init-session* drop ;
@ -24,12 +43,11 @@ M: dispatcher init-session* default>> init-session* ;
M: filter-responder init-session* responder>> init-session* ; M: filter-responder init-session* responder>> init-session* ;
TUPLE: session-manager < filter-responder sessions timeout domain ; TUPLE: sessions < filter-responder timeout domain ;
: <session-manager> ( responder -- responder' ) : <sessions> ( responder -- responder' )
session-manager new sessions new
swap >>responder swap >>responder
null-sessions >>sessions
20 minutes >>timeout ; 20 minutes >>timeout ;
: (session-changed) ( session -- ) : (session-changed) ( session -- )
@ -50,11 +68,11 @@ TUPLE: session-manager < filter-responder sessions timeout domain ;
[ namespace>> swap change-at ] keep [ namespace>> swap change-at ] keep
(session-changed) ; inline (session-changed) ; inline
: init-session ( session managed -- ) : init-session ( session -- )
>r session r> '[ , init-session* ] with-variable ; session [ sessions get init-session* ] with-variable ;
: cutoff-time ( -- time ) : cutoff-time ( -- time )
session-manager get timeout>> from-now timestamp>millis ; sessions get timeout>> from-now timestamp>millis ;
: touch-session ( session -- ) : touch-session ( session -- )
cutoff-time >>expires drop ; cutoff-time >>expires drop ;
@ -64,57 +82,50 @@ TUPLE: session-manager < filter-responder sessions timeout domain ;
H{ } clone >>namespace H{ } clone >>namespace
dup touch-session ; dup touch-session ;
: begin-session ( responder -- session ) : begin-session ( -- session )
>r empty-session r> empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
[ init-session ]
[ sessions>> new-session ]
[ drop ]
2tri ;
! Destructor ! Destructor
TUPLE: session-saver manager session ; TUPLE: session-saver session ;
C: <session-saver> session-saver C: <session-saver> session-saver
M: session-saver dispose M: session-saver dispose
[ session>> ] [ manager>> sessions>> ] bi session>> dup changed?>> [
over changed?>> [ [ touch-session ] [ update-tuple ] bi
[ drop touch-session ] [ update-session ] 2bi ] [ drop ] if ;
] [ 2drop ] if ;
: save-session-after ( manager session -- ) : save-session-after ( session -- )
<session-saver> add-always-destructor ; <session-saver> add-always-destructor ;
: existing-session ( path manager session -- response ) : existing-session ( path session -- response )
[ nip session set ] [ session set ] [ save-session-after ] bi
[ save-session-after ] sessions get responder>> call-responder ;
[ drop responder>> ] 2tri
call-responder ;
: session-id-key "factorsessid" ; : session-id-key "factorsessid" ;
: cookie-session-id ( -- id/f ) : cookie-session-id ( request -- id/f )
request get session-id-key get-cookie session-id-key get-cookie
dup [ value>> string>number ] when ; dup [ value>> string>number ] when ;
: post-session-id ( -- id/f ) : post-session-id ( request -- id/f )
session-id-key request get post-data>> at string>number ; session-id-key swap post-data>> at string>number ;
: request-session-id ( -- id/f ) : request-session-id ( -- id/f )
request get method>> { request get dup method>> {
{ "GET" [ cookie-session-id ] } { "GET" [ cookie-session-id ] }
{ "HEAD" [ cookie-session-id ] } { "HEAD" [ cookie-session-id ] }
{ "POST" [ post-session-id ] } { "POST" [ post-session-id ] }
} case ; } case ;
: request-session ( responder -- session/f ) : request-session ( -- session/f )
>r request-session-id r> sessions>> get-session ; request-session-id get-session ;
: <session-cookie> ( id -- cookie ) : <session-cookie> ( id -- cookie )
session-id-key <cookie> session-id-key <cookie>
"$session-manager" resolve-base-path >>path "$sessions" resolve-base-path >>path
session-manager get timeout>> from-now >>expires sessions get timeout>> from-now >>expires
session-manager get domain>> >>domain ; sessions get domain>> >>domain ;
: put-session-cookie ( response -- response' ) : put-session-cookie ( response -- response' )
session get id>> number>string <session-cookie> put-cookie ; session get id>> number>string <session-cookie> put-cookie ;
@ -126,8 +137,8 @@ M: session-saver dispose
session get id>> number>string =value session get id>> number>string =value
input/> ; input/> ;
M: session-manager call-responder* ( path responder -- response ) M: sessions call-responder* ( path responder -- response )
[ session-form-field ] add-form-hook [ session-form-field ] add-form-hook
dup session-manager set sessions set
dup request-session [ dup begin-session ] unless* request-session [ begin-session ] unless*
existing-session put-session-cookie ; existing-session put-session-cookie ;

29
extra/webapps/counter/counter.factor Normal file
View File

@ -0,0 +1,29 @@
USING: math kernel accessors http.server http.server.actions
http.server.sessions http.server.templating.fhtml locals ;
IN: webapps.counter
SYMBOL: count
TUPLE: counter-app < dispatcher ;
M: counter-app init-session*
drop 0 count sset ;
:: <counter-action> ( quot -- action )
<action> [
count quot schange
"" f <standard-redirect>
] >>display ;
: <display-action> ( -- action )
<action> [
"text/html" <content>
"resource:extra/webapps/counter/counter.fhtml" <fhtml> >>body
] >>display ;
: <counter-app> ( -- responder )
counter-app new-dispatcher
[ 1+ ] <counter-action> "inc" add-responder
[ 1- ] <counter-action> "dec" add-responder
<display-action> "" add-responder
<sessions> ;

10
extra/webapps/counter/counter.fhtml Normal file
View File

@ -0,0 +1,10 @@
<% USING: io math.parser http.server.sessions webapps.counter ; %>
<html>
<body>
<h1><% count sget number>string write %></h1>
<a href="inc">++</a>
<a href="dec">--</a>
</body>
</html>

2
extra/webapps/factor-website/factor-website.factor
View File

@ -47,7 +47,7 @@ IN: webapps.factor-website
<boilerplate> <boilerplate>
"page" factor-template >>template "page" factor-template >>template
<flows> <flows>
<session-manager> <sessions>
sessions-in-db >>sessions sessions-in-db >>sessions
test-db <db-persistence> ; test-db <db-persistence> ;