Persistent sessions

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 ;

extra/http/client/client-tests.factor

@@ -18,6 +18,7 @@ tuple-syntax namespaces ;
         port: 80
         version: "1.1"
         cookies: V{ }
+        header: H{ }
     }
 ] [
     [

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 ;
 

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
+USING: http.server.actions http.server.validators
-multiline namespaces http io.streams.string http.server
+tools.test math math.parser multiline namespaces http
-sequences accessors ;
+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

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? )
+:: validate-param ( name validator assoc -- )
-    swap pick
+    name assoc at validator with-validator name set ; inline
-    >r >r at r> with-validator swap r> set ;
 
 : 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> ] [

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

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 ;
 
-<in-memory> "provider" set
+<users-in-memory> "provider" set
 
 [ t ] [
     <user>

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 ;
 
-: <in-memory> ( -- provider )
+: <users-in-memory> ( -- provider )
-    H{ } clone in-memory construct-boa ;
+    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 ;

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
+    init-users-table
-    [ user create-table ] ignore-errors
 
     [ 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
 

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 ;
+SINGLETON: users-in-db
-
-: from-db T{ from-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 ;

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-users update-user 2drop ;
-
-M: no update-user 2drop ;

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

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

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" <text> validate = ] unit-test

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

extra/http/server/server.factor

@@ -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 [
+        find-responder call-responder
-            2nip
-        ] [
-            default>> [
-                call-responder
-            ] [
-                drop f
-            ] if*
-        ] if*
     ] [
         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 ;

extra/http/server/sessions/sessions-tests.factor

@@ -1,6 +1,8 @@
 IN: http.server.sessions.tests
-USING: tools.test http.server.sessions math namespaces
+USING: tools.test http http.server.sessions
-kernel accessors ;
+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
+        "manager" get begin-session drop
-        dup "manager" get get-session [ 5 "a" sset ] with-session
+        dup "manager" get sessions>> get-session [ 5 "a" sset ] with-session
-        dup "manager" get get-session [ "a" sget , ] with-session
+        dup "manager" get sessions>> get-session [ "a" sget , ] with-session
-        dup "manager" get get-session [ "x" sget , ] with-session
+        dup "manager" get sessions>> get-session [ "x" sget , ] with-session
-        "manager" get get-session delete-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

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 ;
 
 : <session-manager> ( responder class -- responder' )
-    >r H{ } clone session-manager construct-boa r>
+    >r <sessions-in-memory> session-manager construct-boa
-    construct-delegate ; inline
+    r> construct-delegate ; inline
 
-TUPLE: session manager id namespace alarm ;
+SYMBOLS: session session-id session-changed? ;
 
-: <session> ( manager -- session )
+: sget ( key -- value )
-    f H{ } clone <box> \ session construct-boa ;
+    session get at ;
 
-: timeout ( -- dt ) 20 minutes ;
+: sset ( value key -- )
+    session get set-at
+    session-changed? on ;
 
-: cancel-timeout ( session -- )
+: schange ( key quot -- )
-    alarm>> [ cancel-alarm ] if-box? ;
+    session get swap change-at
+    session-changed? on ; inline
 
-: delete-session ( session -- )
+: sessions session-manager get sessions>> ;
-    [ cancel-timeout ]
-    [ dup manager>> sessions>> delete-at ]
-    bi ;
 
-: touch-session ( session -- session )
+: managed-responder session-manager get responder>> ;
-    [ cancel-timeout ]
-    [ [ '[ , delete-session ] timeout later ] keep alarm>> >box ]
-    [ ]
-    tri ;
 
-: 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 )
+M: session-saver dispose
-    dup dup \ session [
+    session-changed? get [
-        manager>> responder>> init-session*
+        [ session>> ] [ id>> ] bi
-    ] with-variable ;
+        sessions update-session
+    ] [ drop ] if ;
 
-: new-session ( responder -- id )
+: call-responder/session ( path responder id session -- response )
-    [ <session> init-session touch-session ]
+    [ <session-saver> add-always-destructor ]
-    [ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ]
+    [ [ session-id set ] [ session set ] bi* ] 2bi
-    bi id>> ;
+    [ session-manager set ] [ responder>> call-responder ] bi ;
-
-: 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 ;
 
 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 )
+: current-url-session ( responder -- id/f session/f )
-    >r request-params sess-id swap at r> get-session ;
+    [ 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
+        "hidden" =type
-    sess-id =id
+        session-id-key =id
-    sess-id =name
+        session-id-key =name
-    \ session get id>> =value
+        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
+        2drop nip new-url-session
-        f swap new-session sess-id associate <temporary-redirect>
+    ] if ;
-    ] if* ;
 
 TUPLE: cookie-sessions ;
 
 : <cookie-sessions> ( responder -- responder' )
     cookie-sessions <session-manager> ;
 
-: get-session-cookie ( responder -- cookie )
+: current-cookie-session ( responder -- id namespace/f )
-    request get sess-id get-cookie
+    request get session-id-key get-cookie dup
-    [ value>> swap get-session ] [ drop f ] if* ;
+    [ 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
+        2drop call-responder/new-session
-        [ over get-session call-responder/session ] keep
+    ] if ;
-        <session-cookie> put-cookie
-    ] if* ;

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 ;
+
+: <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 ;

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

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 ;
+
+: <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 ;

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 )

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

extra/http/server/validators/validators.factor

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