From 234dfc5705e3758b38e025215552d0fb18486851 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 15 Mar 2008 06:22:47 -0500 Subject: [PATCH] Persistent sessions --- extra/assocs/lib/lib.factor | 10 +- extra/http/client/client-tests.factor | 1 + extra/http/http.factor | 1 + .../http/server/actions/actions-tests.factor | 15 ++- extra/http/server/actions/actions.factor | 11 +- extra/http/server/auth/login/login.factor | 4 +- .../auth/providers/assoc/assoc-tests.factor | 2 +- .../server/auth/providers/assoc/assoc.factor | 12 +- .../server/auth/providers/db/db-tests.factor | 7 +- extra/http/server/auth/providers/db/db.factor | 13 +- .../server/auth/providers/null/null.factor | 12 +- .../server/auth/providers/providers.factor | 2 +- extra/http/server/callbacks/callbacks.factor | 2 +- .../server/components/components-tests.factor | 8 ++ .../http/server/components/components.factor | 7 +- extra/http/server/server.factor | 44 +++--- .../server/sessions/sessions-tests.factor | 95 +++++++++++-- extra/http/server/sessions/sessions.factor | 125 +++++++++--------- .../sessions/storage/assoc/assoc.factor | 38 ++++++ .../sessions/storage/db/db-tests.factor | 24 ++++ .../http/server/sessions/storage/db/db.factor | 52 ++++++++ .../server/sessions/storage/storage.factor | 14 ++ .../server/validators/validators-tests.factor | 3 +- .../http/server/validators/validators.factor | 3 + 24 files changed, 366 insertions(+), 139 deletions(-) create mode 100755 extra/http/server/sessions/storage/assoc/assoc.factor create mode 100755 extra/http/server/sessions/storage/db/db-tests.factor create mode 100755 extra/http/server/sessions/storage/db/db.factor create mode 100755 extra/http/server/sessions/storage/storage.factor diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index d2eb42a117..2500940373 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -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 ; diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 661f63ab59..0f684f782a 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -18,6 +18,7 @@ tuple-syntax namespaces ; port: 80 version: "1.1" cookies: V{ } + header: H{ } } ] [ [ diff --git a/extra/http/http.factor b/extra/http/http.factor index 4dd433f85d..421a409639 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -180,6 +180,7 @@ cookies ; request construct-empty "1.1" >>version http-port >>port + H{ } clone >>header H{ } clone >>query V{ } clone >>cookies ; diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 45f7ff385d..c604b8a427 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -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 [ "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 [ +path+ get "xxx" get "X" concat append ] >>submit - { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params + { { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params "action-2" set STRING: action-request-test-2 diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 7bee96edce..91671392c7 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -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> ] [ diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 8842e1639e..a1c99f749c 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -173,7 +173,7 @@ SYMBOL: previous-page dup users update-user logged-in-user sset - previous-page sget dup [ f ] when + previous-page sget f ] >>submit ] ; @@ -347,7 +347,7 @@ M: login call-responder ( path responder -- response ) swap >>default "login" add-responder "logout" add-responder - no >>users ; + no-users >>users ; ! ! ! Configuration diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor index 12c799816d..90ba6e0d53 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -3,7 +3,7 @@ USING: http.server.auth.providers http.server.auth.providers.assoc tools.test namespaces accessors kernel ; - "provider" set + "provider" set [ t ] [ diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor index 8433e54fda..e8ab908406 100755 --- a/extra/http/server/auth/providers/assoc/assoc.factor +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -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 ; -: ( -- provider ) - H{ } clone in-memory construct-boa ; +: ( -- 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 ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index 247359aea4..1ee7278163 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -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 ] [ @@ -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 diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index c9e1328052..aec64d3384 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -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 ) 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 ; diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor index 7b8bfc627c..30f6dbd06e 100755 --- a/extra/http/server/auth/providers/null/null.factor +++ b/extra/http/server/auth/providers/null/null.factor @@ -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 ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index 74620a4f5d..cd9cc995c7 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -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 ] ; diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index ac03e0efc8..45a6ff85f8 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -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 diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index 83ae7b0118..09d31202c5 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -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" validate = ] unit-test diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index df46259c14..02c992651a 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -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 ; : ( id -- component ) number ; 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 ; : ( id -- component ) text ; -M: text validate* 2drop ; +M: text validate* drop ; M: text render-view* drop write ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 60bb5d921d..ce6a1244cb 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -108,10 +108,6 @@ TUPLE: dispatcher default responders ; : ( -- dispatcher ) 404-responder get H{ } clone dispatcher construct-boa ; -: set-main ( dispatcher name -- dispatcher ) - '[ , f ] - >>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 ; +: ( class -- dispatcher ) + swap construct-delegate ; inline + +TUPLE: vhost-dispatcher default responders ; + +: ( -- 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 ] + >>default ; + : add-responder ( dispatcher responder path -- dispatcher ) pick responders>> set-at ; : add-main-responder ( dispatcher responder path -- dispatcher ) [ add-responder ] keep set-main ; -: ( class -- 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 ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 5530b04611..a6a42f9129 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -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 M: foo init-session* drop 0 "x" sset ; -f "123" >>id [ +M: foo call-responder + 2drop + "x" [ 1+ ] schange + "text/html" [ "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 "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? ] unit-test [ t ] [ f cookie-sessions? ] unit-test [ ] [ + >>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 + +[ ] [ + + "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 + [ + + "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 + +[ ] [ + + >>sessions + "manager" set +] unit-test + +[ + + "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 + [ + + "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 diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 260c80914e..76f022e28c 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -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 ; : ( responder class -- responder' ) - >r H{ } clone session-manager construct-boa r> - construct-delegate ; inline + >r session-manager construct-boa + r> construct-delegate ; inline -TUPLE: session manager id namespace alarm ; +SYMBOLS: session session-id session-changed? ; -: ( manager -- session ) - f H{ } clone \ 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 -: 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 ) - [ 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 ) + [ 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 ; M: null-sessions call-responder ( path responder -- response ) - dup call-responder/session ; + H{ } clone f call-responder/session ; TUPLE: url-sessions ; : ( responder -- responder' ) url-sessions ; -: 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 ( -- ) > =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* + ; + 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 - ] if* ; + 2drop nip new-url-session + ] if ; TUPLE: cookie-sessions ; : ( responder -- responder' ) cookie-sessions ; -: 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 ; : ( id -- cookie ) - sess-id ; + session-id-key ; + +: call-responder/new-session ( path responder -- response ) + dup begin-session + [ call-responder/session ] + [ drop ] 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 - put-cookie - ] if* ; + 2drop call-responder/new-session + ] if ; diff --git a/extra/http/server/sessions/storage/assoc/assoc.factor b/extra/http/server/sessions/storage/assoc/assoc.factor new file mode 100755 index 0000000000..1339e3c867 --- /dev/null +++ b/extra/http/server/sessions/storage/assoc/assoc.factor @@ -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 ; + +: ( -- 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 ; diff --git a/extra/http/server/sessions/storage/db/db-tests.factor b/extra/http/server/sessions/storage/db/db-tests.factor new file mode 100755 index 0000000000..4e6ae8a9b4 --- /dev/null +++ b/extra/http/server/sessions/storage/db/db-tests.factor @@ -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 diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor new file mode 100755 index 0000000000..6ef655bde2 --- /dev/null +++ b/extra/http/server/sessions/storage/db/db.factor @@ -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 ; + +: ( 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 [ + + 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 + + swap global [ dup . ] bind >>namespace + dup update-tuple + id>> select-tuple global [ . flush ] bind + ; + +M: sessions-in-db delete-session ( id storage -- ) + drop + + delete-tuple ; + +M: sessions-in-db new-session ( namespace storage -- id ) + global [ "new " print flush ] bind + drop + f + swap global [ dup . ] bind >>namespace + [ insert-tuple ] [ id>> number>string ] bi ; diff --git a/extra/http/server/sessions/storage/storage.factor b/extra/http/server/sessions/storage/storage.factor new file mode 100755 index 0000000000..df96c815c7 --- /dev/null +++ b/extra/http/server/sessions/storage/storage.factor @@ -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 ) diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor index d0785b0126..82827ac450 100755 --- a/extra/http/server/validators/validators-tests.factor +++ b/extra/http/server/validators/validators-tests.factor @@ -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 diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor index 84f22b01f4..539a58d19f 100755 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -40,6 +40,9 @@ C: 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