Persistent sessions
Slava Pestov
parent
b6fece6314
commit
234dfc5705
|
|
@ -1,4 +1,5 @@
|
|||
USING: arrays assocs kernel vectors sequences namespaces ;
|
||||
USING: arrays assocs kernel vectors sequences namespaces
|
||||
random math.parser ;
|
||||
IN: assocs.lib
|
||||
|
||||
: >set ( seq -- hash )
|
||||
|
|
@ -38,3 +39,10 @@ IN: assocs.lib
|
|||
|
||||
: 2seq>assoc ( keys values exemplar -- assoc )
|
||||
>r 2array flip r> assoc-like ;
|
||||
|
||||
: generate-key ( assoc -- str )
|
||||
>r random-256 >hex r>
|
||||
2dup key? [ nip generate-key ] [ drop ] if ;
|
||||
|
||||
: set-at-unique ( value assoc -- key )
|
||||
dup generate-key [ swap set-at ] keep ;
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@ tuple-syntax namespaces ;
|
|||
port: 80
|
||||
version: "1.1"
|
||||
cookies: V{ }
|
||||
header: H{ }
|
||||
}
|
||||
] [
|
||||
[
|
||||
|
|
|
|||
|
|
@ -180,6 +180,7 @@ cookies ;
|
|||
request construct-empty
|
||||
"1.1" >>version
|
||||
http-port >>port
|
||||
H{ } clone >>header
|
||||
H{ } clone >>query
|
||||
V{ } clone >>cookies ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,16 @@
|
|||
IN: http.server.actions.tests
|
||||
USING: http.server.actions tools.test math math.parser
|
||||
multiline namespaces http io.streams.string http.server
|
||||
sequences accessors ;
|
||||
USING: http.server.actions http.server.validators
|
||||
tools.test math math.parser multiline namespaces http
|
||||
io.streams.string http.server sequences accessors ;
|
||||
|
||||
[
|
||||
"a" [ v-number ] { { "a" "123" } } validate-param
|
||||
[ 123 ] [ "a" get ] unit-test
|
||||
] with-scope
|
||||
|
||||
<action>
|
||||
[ "a" get "b" get + ] >>display
|
||||
{ { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params
|
||||
{ { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
|
||||
"action-1" set
|
||||
|
||||
STRING: action-request-test-1
|
||||
|
|
@ -23,7 +28,7 @@ blah
|
|||
|
||||
<action>
|
||||
[ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
|
||||
{ { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
|
||||
{ { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params
|
||||
"action-2" set
|
||||
|
||||
STRING: action-request-test-2
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors new-slots sequences kernel assocs combinators
|
||||
http.server http.server.validators http hashtables namespaces
|
||||
combinators.cleave fry continuations ;
|
||||
combinators.cleave fry continuations locals ;
|
||||
IN: http.server.actions
|
||||
|
||||
SYMBOL: +path+
|
||||
|
|
@ -17,12 +17,13 @@ TUPLE: action init display submit get-params post-params ;
|
|||
[ <400> ] >>display
|
||||
[ <400> ] >>submit ;
|
||||
|
||||
: validate-param ( name validator assoc -- error? )
|
||||
swap pick
|
||||
>r >r at r> with-validator swap r> set ;
|
||||
:: validate-param ( name validator assoc -- )
|
||||
name assoc at validator with-validator name set ; inline
|
||||
|
||||
: action-params ( validators -- error? )
|
||||
[ params get validate-param ] { } assoc>map [ ] contains? ;
|
||||
validation-failed? off
|
||||
params get '[ , validate-param ] assoc-each
|
||||
validation-failed? get ;
|
||||
|
||||
: handle-get ( -- response )
|
||||
action get get-params>> action-params [ <400> ] [
|
||||
|
|
|
|||
|
|
@ -173,7 +173,7 @@ SYMBOL: previous-page
|
|||
dup users update-user
|
||||
logged-in-user sset
|
||||
|
||||
previous-page sget dup [ f <permanent-redirect> ] when
|
||||
previous-page sget f <permanent-redirect>
|
||||
] >>submit
|
||||
] ;
|
||||
|
||||
|
|
@ -347,7 +347,7 @@ M: login call-responder ( path responder -- response )
|
|||
swap <protected> >>default
|
||||
<login-action> "login" add-responder
|
||||
<logout-action> "logout" add-responder
|
||||
no >>users ;
|
||||
no-users >>users ;
|
||||
|
||||
! ! ! Configuration
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ USING: http.server.auth.providers
|
|||
http.server.auth.providers.assoc tools.test
|
||||
namespaces accessors kernel ;
|
||||
|
||||
<in-memory> "provider" set
|
||||
<users-in-memory> "provider" set
|
||||
|
||||
[ t ] [
|
||||
<user>
|
||||
|
|
|
|||
|
|
@ -4,16 +4,16 @@ IN: http.server.auth.providers.assoc
|
|||
USING: new-slots accessors assocs kernel
|
||||
http.server.auth.providers ;
|
||||
|
||||
TUPLE: in-memory assoc ;
|
||||
TUPLE: users-in-memory assoc ;
|
||||
|
||||
: <in-memory> ( -- provider )
|
||||
H{ } clone in-memory construct-boa ;
|
||||
: <users-in-memory> ( -- provider )
|
||||
H{ } clone users-in-memory construct-boa ;
|
||||
|
||||
M: in-memory get-user ( username provider -- user/f )
|
||||
M: users-in-memory get-user ( username provider -- user/f )
|
||||
assoc>> at ;
|
||||
|
||||
M: in-memory update-user ( user provider -- ) 2drop ;
|
||||
M: users-in-memory update-user ( user provider -- ) 2drop ;
|
||||
|
||||
M: in-memory new-user ( user provider -- user/f )
|
||||
M: users-in-memory new-user ( user provider -- user/f )
|
||||
>r dup username>> r> assoc>>
|
||||
2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;
|
||||
|
|
|
|||
|
|
@ -4,12 +4,11 @@ http.server.auth.providers.db tools.test
|
|||
namespaces db db.sqlite db.tuples continuations
|
||||
io.files accessors kernel ;
|
||||
|
||||
from-db "provider" set
|
||||
users-in-db "provider" set
|
||||
|
||||
"auth-test.db" temp-file sqlite-db [
|
||||
|
||||
[ user drop-table ] ignore-errors
|
||||
[ user create-table ] ignore-errors
|
||||
init-users-table
|
||||
|
||||
[ t ] [
|
||||
<user>
|
||||
|
|
@ -32,7 +31,7 @@ from-db "provider" set
|
|||
|
||||
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
|
||||
|
||||
[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test
|
||||
[ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test
|
||||
|
||||
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: db db.tuples db.types new-slots accessors
|
||||
http.server.auth.providers kernel continuations ;
|
||||
http.server.auth.providers kernel continuations
|
||||
singleton ;
|
||||
IN: http.server.auth.providers.db
|
||||
|
||||
user "USERS"
|
||||
|
|
@ -16,20 +17,18 @@ user "USERS"
|
|||
|
||||
: init-users-table user ensure-table ;
|
||||
|
||||
TUPLE: from-db ;
|
||||
|
||||
: from-db T{ from-db } ;
|
||||
SINGLETON: users-in-db
|
||||
|
||||
: find-user ( username -- user )
|
||||
<user>
|
||||
swap >>username
|
||||
select-tuple ;
|
||||
|
||||
M: from-db get-user
|
||||
M: users-in-db get-user
|
||||
drop
|
||||
find-user ;
|
||||
|
||||
M: from-db new-user
|
||||
M: users-in-db new-user
|
||||
drop
|
||||
[
|
||||
dup username>> find-user [
|
||||
|
|
@ -39,5 +38,5 @@ M: from-db new-user
|
|||
] if
|
||||
] with-transaction ;
|
||||
|
||||
M: from-db update-user
|
||||
M: users-in-db update-user
|
||||
drop update-tuple ;
|
||||
|
|
|
|||
|
|
@ -3,14 +3,12 @@
|
|||
USING: http.server.auth.providers kernel ;
|
||||
IN: http.server.auth.providers.null
|
||||
|
||||
! Named "no" because we can say no >>users
|
||||
TUPLE: no-users ;
|
||||
|
||||
TUPLE: no ;
|
||||
: no-users T{ no-users } ;
|
||||
|
||||
: no T{ no } ;
|
||||
M: no-users get-user 2drop f ;
|
||||
|
||||
M: no get-user 2drop f ;
|
||||
M: no-users new-user 2drop f ;
|
||||
|
||||
M: no new-user 2drop f ;
|
||||
|
||||
M: no update-user 2drop ;
|
||||
M: no-users update-user 2drop ;
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ GENERIC: new-user ( user provider -- user/f )
|
|||
user [
|
||||
user
|
||||
password >>password
|
||||
provider dup update-user
|
||||
dup provider update-user
|
||||
] [ f ] if
|
||||
] ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
USING: html http http.server io kernel math namespaces
|
||||
continuations calendar sequences assocs new-slots hashtables
|
||||
accessors arrays alarms quotations combinators
|
||||
combinators.cleave fry ;
|
||||
combinators.cleave fry assocs.lib ;
|
||||
IN: http.server.callbacks
|
||||
|
||||
SYMBOL: responder
|
||||
|
|
|
|||
|
|
@ -98,4 +98,12 @@ TUPLE: test-tuple text number more-text ;
|
|||
[ "123" ] [
|
||||
"123" "n" get validate value>>
|
||||
] unit-test
|
||||
|
||||
[ ] [ "n" get t >>integer drop ] unit-test
|
||||
|
||||
[ 3 ] [
|
||||
"3" "n" get validate
|
||||
] unit-test
|
||||
] with-scope
|
||||
|
||||
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test
|
||||
|
|
|
|||
|
|
@ -187,15 +187,16 @@ M: password render-error*
|
|||
render-edit* render-error ;
|
||||
|
||||
! Number fields
|
||||
TUPLE: number min-value max-value ;
|
||||
TUPLE: number min-value max-value integer ;
|
||||
|
||||
: <number> ( id -- component ) number <component> ;
|
||||
|
||||
M: number validate*
|
||||
[ v-number ] [
|
||||
[ integer>> [ v-integer ] when ]
|
||||
[ min-value>> [ v-min-value ] when* ]
|
||||
[ max-value>> [ v-max-value ] when* ]
|
||||
bi
|
||||
tri
|
||||
] bi* ;
|
||||
|
||||
M: number render-view*
|
||||
|
|
@ -212,7 +213,7 @@ TUPLE: text ;
|
|||
|
||||
: <text> ( id -- component ) text <component> ;
|
||||
|
||||
M: text validate* 2drop ;
|
||||
M: text validate* drop ;
|
||||
|
||||
M: text render-view*
|
||||
drop write ;
|
||||
|
|
|
|||
|
|
@ -108,10 +108,6 @@ TUPLE: dispatcher default responders ;
|
|||
: <dispatcher> ( -- dispatcher )
|
||||
404-responder get H{ } clone dispatcher construct-boa ;
|
||||
|
||||
: set-main ( dispatcher name -- dispatcher )
|
||||
'[ , f <permanent-redirect> ] <trivial-responder>
|
||||
>>default ;
|
||||
|
||||
: split-path ( path -- rest first )
|
||||
[ CHAR: / = ] left-trim "/" split1 swap ;
|
||||
|
||||
|
|
@ -124,28 +120,36 @@ TUPLE: dispatcher default responders ;
|
|||
|
||||
M: dispatcher call-responder ( path dispatcher -- response )
|
||||
over [
|
||||
2dup find-responder call-responder [
|
||||
2nip
|
||||
] [
|
||||
default>> [
|
||||
call-responder
|
||||
] [
|
||||
drop f
|
||||
] if*
|
||||
] if*
|
||||
find-responder call-responder
|
||||
] [
|
||||
2drop redirect-with-/
|
||||
] if ;
|
||||
|
||||
: <webapp> ( class -- dispatcher )
|
||||
<dispatcher> swap construct-delegate ; inline
|
||||
|
||||
TUPLE: vhost-dispatcher default responders ;
|
||||
|
||||
: <vhost-dispatcher> ( -- dispatcher )
|
||||
404-responder get H{ } clone vhost-dispatcher construct-boa ;
|
||||
|
||||
: find-vhost ( dispatcher -- responder )
|
||||
request get host>> over responders>> at*
|
||||
[ nip ] [ drop default>> ] if ;
|
||||
|
||||
M: vhost-dispatcher call-responder ( path dispatcher -- response )
|
||||
find-vhost call-responder ;
|
||||
|
||||
: set-main ( dispatcher name -- dispatcher )
|
||||
'[ , f <permanent-redirect> ] <trivial-responder>
|
||||
>>default ;
|
||||
|
||||
: add-responder ( dispatcher responder path -- dispatcher )
|
||||
pick responders>> set-at ;
|
||||
|
||||
: add-main-responder ( dispatcher responder path -- dispatcher )
|
||||
[ add-responder ] keep set-main ;
|
||||
|
||||
: <webapp> ( class -- dispatcher )
|
||||
<dispatcher> swap construct-delegate ; inline
|
||||
|
||||
SYMBOL: main-responder
|
||||
|
||||
main-responder global
|
||||
|
|
@ -219,11 +223,3 @@ SYMBOL: exit-continuation
|
|||
: httpd-main ( -- ) 8888 httpd ;
|
||||
|
||||
MAIN: httpd-main
|
||||
|
||||
! Utility
|
||||
: generate-key ( assoc -- str )
|
||||
>r random-256 >hex r>
|
||||
2dup key? [ nip generate-key ] [ drop ] if ;
|
||||
|
||||
: set-at-unique ( value assoc -- key )
|
||||
dup generate-key [ swap set-at ] keep ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
IN: http.server.sessions.tests
|
||||
USING: tools.test http.server.sessions math namespaces
|
||||
kernel accessors ;
|
||||
USING: tools.test http http.server.sessions
|
||||
http.server.sessions.storage http.server.sessions.storage.assoc
|
||||
http.server math namespaces kernel accessors prettyprint
|
||||
io.streams.string splitting destructors ;
|
||||
|
||||
[ H{ } ] [ H{ } add-session-id ] unit-test
|
||||
|
||||
|
|
@ -12,7 +14,16 @@ C: <foo> foo
|
|||
|
||||
M: foo init-session* drop 0 "x" sset ;
|
||||
|
||||
f <session> "123" >>id [
|
||||
M: foo call-responder
|
||||
2drop
|
||||
"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
|
||||
|
|
@ -22,22 +33,88 @@ f <session> "123" >>id [
|
|||
[ ] [ "x" [ 1- ] schange ] unit-test
|
||||
|
||||
[ 4 ] [ "x" sget sq ] unit-test
|
||||
] with-session
|
||||
|
||||
[ 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 new-session
|
||||
dup "manager" get get-session [ 5 "a" sset ] with-session
|
||||
dup "manager" get get-session [ "a" sget , ] with-session
|
||||
dup "manager" get get-session [ "x" sget , ] with-session
|
||||
"manager" get get-session delete-session
|
||||
"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>
|
||||
"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
|
||||
[ "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>
|
||||
"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
|
||||
[ "3" ] [ cookie-responder-mock-test ] unit-test
|
||||
[ "4" ] [ cookie-responder-mock-test ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs calendar kernel math.parser namespaces random
|
||||
boxes alarms new-slots accessors http http.server
|
||||
new-slots accessors http http.server
|
||||
http.server.sessions.storage http.server.sessions.storage.assoc
|
||||
quotations hashtables sequences fry combinators.cleave
|
||||
html.elements ;
|
||||
html.elements symbols continuations destructors ;
|
||||
IN: http.server.sessions
|
||||
|
||||
! ! ! ! ! !
|
||||
|
|
@ -17,56 +18,48 @@ M: dispatcher init-session* drop ;
|
|||
TUPLE: session-manager responder sessions ;
|
||||
|
||||
: <session-manager> ( responder class -- responder' )
|
||||
>r H{ } clone session-manager construct-boa r>
|
||||
construct-delegate ; inline
|
||||
>r <sessions-in-memory> session-manager construct-boa
|
||||
r> construct-delegate ; inline
|
||||
|
||||
TUPLE: session manager id namespace alarm ;
|
||||
SYMBOLS: session session-id session-changed? ;
|
||||
|
||||
: <session> ( manager -- session )
|
||||
f H{ } clone <box> \ session construct-boa ;
|
||||
: sget ( key -- value )
|
||||
session get at ;
|
||||
|
||||
: timeout ( -- dt ) 20 minutes ;
|
||||
: sset ( value key -- )
|
||||
session get set-at
|
||||
session-changed? on ;
|
||||
|
||||
: cancel-timeout ( session -- )
|
||||
alarm>> [ cancel-alarm ] if-box? ;
|
||||
: schange ( key quot -- )
|
||||
session get swap change-at
|
||||
session-changed? on ; inline
|
||||
|
||||
: delete-session ( session -- )
|
||||
[ cancel-timeout ]
|
||||
[ dup manager>> sessions>> delete-at ]
|
||||
bi ;
|
||||
: sessions session-manager get sessions>> ;
|
||||
|
||||
: touch-session ( session -- session )
|
||||
[ cancel-timeout ]
|
||||
[ [ '[ , delete-session ] timeout later ] keep alarm>> >box ]
|
||||
[ ]
|
||||
tri ;
|
||||
: managed-responder session-manager get responder>> ;
|
||||
|
||||
: session ( -- assoc ) \ session get namespace>> ;
|
||||
: init-session ( managed -- session )
|
||||
H{ } clone [ session [ init-session* ] with-variable ] keep ;
|
||||
|
||||
: sget ( key -- value ) session at ;
|
||||
: begin-session ( responder -- id session )
|
||||
[ responder>> init-session ] [ sessions>> ] bi
|
||||
[ new-session ] [ drop ] 2bi ;
|
||||
|
||||
: sset ( value key -- ) session set-at ;
|
||||
! Destructor
|
||||
TUPLE: session-saver id session ;
|
||||
|
||||
: schange ( key quot -- ) session swap change-at ; inline
|
||||
C: <session-saver> session-saver
|
||||
|
||||
: init-session ( session -- session )
|
||||
dup dup \ session [
|
||||
manager>> responder>> init-session*
|
||||
] with-variable ;
|
||||
M: session-saver dispose
|
||||
session-changed? get [
|
||||
[ session>> ] [ id>> ] bi
|
||||
sessions update-session
|
||||
] [ drop ] if ;
|
||||
|
||||
: new-session ( responder -- id )
|
||||
[ <session> init-session touch-session ]
|
||||
[ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ]
|
||||
bi id>> ;
|
||||
|
||||
: get-session ( id responder -- session/f )
|
||||
sessions>> at* [ touch-session ] when ;
|
||||
|
||||
: call-responder/session ( path responder session -- response )
|
||||
\ session set responder>> call-responder ;
|
||||
|
||||
: sessions ( -- manager/f )
|
||||
\ session get dup [ manager>> ] when ;
|
||||
: call-responder/session ( path responder id session -- response )
|
||||
[ <session-saver> add-always-destructor ]
|
||||
[ [ session-id set ] [ session set ] bi* ] 2bi
|
||||
[ session-manager set ] [ responder>> call-responder ] bi ;
|
||||
|
||||
TUPLE: null-sessions ;
|
||||
|
||||
|
|
@ -74,56 +67,64 @@ TUPLE: null-sessions ;
|
|||
null-sessions <session-manager> ;
|
||||
|
||||
M: null-sessions call-responder ( path responder -- response )
|
||||
dup <session> call-responder/session ;
|
||||
H{ } clone f call-responder/session ;
|
||||
|
||||
TUPLE: url-sessions ;
|
||||
|
||||
: <url-sessions> ( responder -- responder' )
|
||||
url-sessions <session-manager> ;
|
||||
|
||||
: sess-id "factorsessid" ;
|
||||
: session-id-key "factorsessid" ;
|
||||
|
||||
: current-session ( responder -- session )
|
||||
>r request-params sess-id swap at r> get-session ;
|
||||
: current-url-session ( responder -- id/f session/f )
|
||||
[ request-params session-id-key swap at ] [ sessions>> ] bi*
|
||||
[ drop ] [ get-session ] 2bi ;
|
||||
|
||||
: add-session-id ( query -- query' )
|
||||
\ session get [ id>> sess-id associate union ] when* ;
|
||||
session-id get [ session-id-key associate union ] when* ;
|
||||
|
||||
: session-form-field ( -- )
|
||||
<input
|
||||
"hidden" =type
|
||||
sess-id =id
|
||||
sess-id =name
|
||||
\ session get id>> =value
|
||||
"hidden" =type
|
||||
session-id-key =id
|
||||
session-id-key =name
|
||||
session-id get =value
|
||||
input/> ;
|
||||
|
||||
: new-url-session ( responder -- response )
|
||||
[ f ] [ begin-session drop 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-session [
|
||||
dup current-url-session dup [
|
||||
call-responder/session
|
||||
] [
|
||||
nip
|
||||
f swap new-session sess-id associate <temporary-redirect>
|
||||
] if* ;
|
||||
2drop nip new-url-session
|
||||
] if ;
|
||||
|
||||
TUPLE: cookie-sessions ;
|
||||
|
||||
: <cookie-sessions> ( responder -- responder' )
|
||||
cookie-sessions <session-manager> ;
|
||||
|
||||
: get-session-cookie ( responder -- cookie )
|
||||
request get sess-id get-cookie
|
||||
[ value>> swap get-session ] [ drop f ] if* ;
|
||||
: current-cookie-session ( responder -- id namespace/f )
|
||||
request get session-id-key get-cookie dup
|
||||
[ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ;
|
||||
|
||||
: <session-cookie> ( id -- cookie )
|
||||
sess-id <cookie> ;
|
||||
session-id-key <cookie> ;
|
||||
|
||||
: call-responder/new-session ( path responder -- response )
|
||||
dup begin-session
|
||||
[ call-responder/session ]
|
||||
[ drop <session-cookie> ] 2bi
|
||||
put-cookie ;
|
||||
|
||||
M: cookie-sessions call-responder ( path responder -- response )
|
||||
dup get-session-cookie [
|
||||
dup current-cookie-session dup [
|
||||
call-responder/session
|
||||
] [
|
||||
dup new-session
|
||||
[ over get-session call-responder/session ] keep
|
||||
<session-cookie> put-cookie
|
||||
] if* ;
|
||||
2drop call-responder/new-session
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs assocs.lib new-slots accessors
|
||||
http.server.sessions.storage combinators.cleave 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 construct-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 ;
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs new-slots accessors http.server.sessions.storage
|
||||
alarms kernel http.server db.tuples db.types singleton
|
||||
combinators.cleave math.parser ;
|
||||
IN: http.server.sessions.storage.db
|
||||
|
||||
SINGLETON: sessions-in-db
|
||||
|
||||
TUPLE: session id namespace ;
|
||||
|
||||
session "SESSIONS"
|
||||
{
|
||||
{ "id" "ID" INTEGER +native-id+ }
|
||||
{ "namespace" "NAMESPACE" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
: init-sessions-table session ensure-table ;
|
||||
|
||||
: <session> ( id -- session )
|
||||
session construct-empty
|
||||
swap dup [ string>number ] when >>id ;
|
||||
|
||||
USING: namespaces io prettyprint ;
|
||||
M: sessions-in-db get-session ( id storage -- namespace/f )
|
||||
global [ "get " write over print flush ] bind
|
||||
drop
|
||||
dup [
|
||||
<session>
|
||||
select-tuple dup [ namespace>> ] when global [ dup . ] bind
|
||||
] when ;
|
||||
|
||||
M: sessions-in-db update-session ( namespace id storage -- )
|
||||
global [ "update " write over print flush ] bind
|
||||
drop
|
||||
<session>
|
||||
swap global [ dup . ] bind >>namespace
|
||||
dup update-tuple
|
||||
id>> <session> select-tuple global [ . flush ] bind
|
||||
;
|
||||
|
||||
M: sessions-in-db delete-session ( id storage -- )
|
||||
drop
|
||||
<session>
|
||||
delete-tuple ;
|
||||
|
||||
M: sessions-in-db new-session ( namespace storage -- id )
|
||||
global [ "new " print flush ] bind
|
||||
drop
|
||||
f <session>
|
||||
swap global [ dup . ] bind >>namespace
|
||||
[ insert-tuple ] [ id>> number>string ] bi ;
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: calendar ;
|
||||
IN: http.server.sessions.storage
|
||||
|
||||
: timeout 20 minutes ;
|
||||
|
||||
GENERIC: get-session ( id storage -- namespace )
|
||||
|
||||
GENERIC: update-session ( namespace id storage -- )
|
||||
|
||||
GENERIC: delete-session ( id storage -- )
|
||||
|
||||
GENERIC: new-session ( namespace storage -- id )
|
||||
|
|
@ -2,7 +2,8 @@ IN: http.server.validators.tests
|
|||
USING: kernel sequences tools.test http.server.validators
|
||||
accessors ;
|
||||
|
||||
[ "foo" v-number ] [ validation-error? ] must-fail-with
|
||||
[ "foo" v-number ] must-fail
|
||||
[ 123 ] [ "123" v-number ] unit-test
|
||||
|
||||
[ "slava@factorcode.org" ] [
|
||||
"slava@factorcode.org" v-email
|
||||
|
|
|
|||
|
|
@ -40,6 +40,9 @@ C: <validation-error> validation-error
|
|||
: v-number ( str -- n )
|
||||
dup string>number [ ] [ "must be a number" throw ] ?if ;
|
||||
|
||||
: v-integer ( n -- n )
|
||||
dup integer? [ "must be an integer" throw ] unless ;
|
||||
|
||||
: v-min-value ( x n -- x )
|
||||
2dup < [
|
||||
[ "must be at least " % # ] "" make throw
|
||||
|
|
|
|||
Loading…
Reference in New Issue