From 7d16edcc79642d90bad7ed49362d114d854b69c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 26 Apr 2008 18:56:51 -0500 Subject: [PATCH] Merge URL and cookie session managers, clean up some code --- extra/http/http-tests.factor | 4 +- extra/http/server/auth/auth.factor | 12 ++- extra/http/server/auth/basic/basic.factor | 4 +- extra/http/server/auth/login/login.factor | 11 +-- .../server/boilerplate/boilerplate.factor | 6 +- extra/http/server/db/db.factor | 6 +- extra/http/server/flows/flows.factor | 6 +- extra/http/server/server-tests.factor | 2 + extra/http/server/server.factor | 5 + .../server/sessions/sessions-tests.factor | 41 ++------ extra/http/server/sessions/sessions.factor | 93 +++++++------------ extra/webapps/pastebin/pastebin.factor | 5 +- extra/webapps/todo/todo.factor | 1 + 13 files changed, 80 insertions(+), 116 deletions(-) diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 553b4f2cda..a9e539c2a5 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -194,7 +194,7 @@ test-db [ - + sessions-in-db >>sessions "" add-responder add-quit-action @@ -225,7 +225,7 @@ test-db [ [ "text/plain" [ "Hi" write ] >>body ] >>display - + sessions-in-db >>sessions "" add-responder add-quit-action diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor index 69a3c76c2b..6b5a426102 100755 --- a/extra/http/server/auth/auth.factor +++ b/extra/http/server/auth/auth.factor @@ -1,7 +1,9 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: http.server.sessions accessors -http.server.auth.providers assocs namespaces kernel ; +USING: accessors assocs namespaces kernel +http.server +http.server.sessions +http.server.auth.providers ; IN: http.server.auth SYMBOL: logged-in-user @@ -11,6 +13,12 @@ GENERIC: init-user-profile ( responder -- ) M: object init-user-profile drop ; +M: dispatcher init-user-profile + default>> init-user-profile ; + +M: filter-responder init-user-profile + responder>> init-user-profile ; + : uid ( -- string ) logged-in-user sget username>> ; : profile ( -- assoc ) logged-in-user sget profile>> ; diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor index 04c0e62d07..62625e116b 100755 --- a/extra/http/server/auth/basic/basic.factor +++ b/extra/http/server/auth/basic/basic.factor @@ -6,7 +6,7 @@ http.server.auth.providers http.server.auth.providers.null http sequences ; IN: http.server.auth.basic -TUPLE: basic-auth responder realm provider ; +TUPLE: basic-auth < filter-responder realm provider ; C: basic-auth @@ -38,4 +38,4 @@ C: basic-auth M: basic-auth call-responder ( request path responder -- response ) pick over logged-in? - [ responder>> call-responder ] [ 2nip realm>> <401> ] if ; + [ call-next-method ] [ 2nip realm>> <401> ] if ; diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 413e0a3cf4..5f58f51adb 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -138,7 +138,7 @@ SYMBOL: user-exists? successful-login - login get default>> responder>> init-user-profile + login get init-user-profile ] >>submit ] ; @@ -177,7 +177,8 @@ SYMBOL: user-exists? logged-in-user sget - "password" value empty? [ + { "password" "new-password" "verify-password" } + [ value empty? ] all? [ same-password-twice "password" value uid users check-login @@ -335,12 +336,10 @@ SYMBOL: lost-password-from ! ! ! Authentication logic -TUPLE: protected responder ; +TUPLE: protected < filter-responder ; C: protected -M: protected init-session* responder>> init-session* ; - : show-login-page ( -- response ) begin-flow "$login/login" f ; @@ -348,7 +347,7 @@ M: protected init-session* responder>> init-session* ; M: protected call-responder ( path responder -- response ) logged-in-user sget dup [ save-user-after - responder>> call-responder + call-next-method ] [ 3drop request get method>> { "GET" "HEAD" } member? diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor index bfa79e1a4e..fbe027cc05 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -9,12 +9,10 @@ http.server.sessions http.server.templating ; IN: http.server.boilerplate -TUPLE: boilerplate responder template ; +TUPLE: boilerplate < filter-responder template ; : f boilerplate boa ; -M: boilerplate init-session* responder>> init-session* ; - SYMBOL: title : set-title ( string -- ) @@ -71,7 +69,7 @@ M: f call-template* drop call-next-template ; ] with-scope ; inline M: boilerplate call-responder - tuck responder>> call-responder + tuck call-next-method dup "content-type" header "text/html" = [ clone swap template>> [ [ with-boilerplate ] 2curry ] curry change-body diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index 0e08705fa8..221608fc91 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -4,9 +4,7 @@ USING: db http.server http.server.sessions kernel accessors continuations namespaces destructors ; IN: http.server.db -TUPLE: db-persistence responder db params ; - -M: db-persistence init-session* responder>> init-session* ; +TUPLE: db-persistence < filter-responder db params ; C: db-persistence @@ -15,4 +13,4 @@ C: db-persistence [ db set ] [ add-always-destructor ] bi ; M: db-persistence call-responder - [ connect-db ] [ responder>> call-responder ] bi ; + [ connect-db ] [ call-next-method ] bi ; diff --git a/extra/http/server/flows/flows.factor b/extra/http/server/flows/flows.factor index f6e8d051ce..14ac1d8d79 100644 --- a/extra/http/server/flows/flows.factor +++ b/extra/http/server/flows/flows.factor @@ -5,7 +5,7 @@ assocs assocs.lib hashtables math.parser html.elements http http.server http.server.sessions ; IN: http.server.flows -TUPLE: flows responder ; +TUPLE: flows < filter-responder ; C: flows @@ -43,8 +43,8 @@ M: flows call-responder [ add-flow-id ] add-link-hook [ flow-form-field ] add-form-hook flow-id-key request-params at flow-id set - responder>> call-responder ; + call-next-method ; M: flows init-session* H{ } clone flows sset - responder>> init-session* ; + call-next-method ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 84e873d001..2048164884 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -11,6 +11,8 @@ IN: http.server.tests { { "a" "b" } } >>query request set + [ ] link-hook set + [ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test [ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test [ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index e51cb70de5..13ed36ec65 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -181,6 +181,11 @@ M: vhost-dispatcher call-responder ( path dispatcher -- response ) [ drop "" add-responder drop ] [ 2drop ] 3tri ; +TUPLE: filter-responder responder ; + +M: filter-responder call-responder + responder>> call-responder ; + SYMBOL: main-responder main-responder global diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 85adf7e69f..4ff26c3a8f 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -32,7 +32,7 @@ M: foo call-responder [ write-response-body drop ] with-string-writer ] with-destructors ; -: cookie-responder-mock-test +: session-manager-mock-test [ "GET" >>method @@ -58,9 +58,6 @@ M: foo call-responder [ empty-session 123 >>id session set - session-changed? off - - [ H{ { "factorsessid" 123 } } ] [ H{ } add-session-id ] unit-test [ ] [ 3 "x" sset ] unit-test @@ -70,14 +67,11 @@ M: foo call-responder [ 4 ] [ "x" sget sq ] unit-test - [ t ] [ session-changed? get ] unit-test + [ t ] [ session get changed?>> ] unit-test ] with-scope - [ t ] [ f url-sessions? ] unit-test - [ t ] [ f cookie-sessions? ] unit-test - [ ] [ - + sessions-in-db >>sessions session-manager set ] unit-test @@ -113,26 +107,7 @@ M: foo call-responder ] unit-test [ ] [ - [ - - "GET" >>method - request set - { "etc" } session-manager get call-responder - ] with-destructors - response set - ] unit-test - - [ 307 ] [ response get code>> ] unit-test - - [ ] [ response get "location" header "=" split1 nip "id" set ] unit-test - - [ "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-in-db >>sessions session-manager set ] unit-test @@ -150,9 +125,9 @@ M: foo call-responder [ ] [ response get cookies>> "cookies" set ] unit-test - [ "2" ] [ cookie-responder-mock-test ] unit-test - [ "3" ] [ cookie-responder-mock-test ] unit-test - [ "4" ] [ cookie-responder-mock-test ] unit-test + [ "2" ] [ session-manager-mock-test ] unit-test + [ "3" ] [ session-manager-mock-test ] unit-test + [ "4" ] [ session-manager-mock-test ] unit-test [ [ ] [ @@ -163,7 +138,7 @@ M: foo call-responder request set [ - { } + { } sessions-in-db >>sessions call-responder ] with-destructors response set diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 96d1c3beca..d2c1d90e0a 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel math.parser namespaces random accessors quotations hashtables sequences continuations -fry calendar destructors +fry calendar combinators destructors http http.server http.server.sessions.storage @@ -22,12 +22,12 @@ M: object init-session* drop ; M: dispatcher init-session* default>> init-session* ; -TUPLE: session-manager responder sessions ; +M: filter-responder init-session* responder>> init-session* ; -: new-session-manager ( responder class -- responder' ) - new - null-sessions >>sessions - swap >>responder ; inline +TUPLE: session-manager < filter-responder sessions ; + +: ( responder -- responder' ) + null-sessions session-manager boa ; : (session-changed) ( session -- ) t >>changed? drop ; @@ -49,8 +49,6 @@ TUPLE: session-manager responder sessions ; : sessions session-manager get sessions>> ; -: managed-responder session-manager get responder>> ; - : init-session ( session managed -- ) >r session r> '[ , init-session* ] with-variable ; @@ -69,7 +67,7 @@ TUPLE: session-manager responder sessions ; : begin-session ( responder -- session ) >r empty-session r> - [ responder>> init-session ] + [ init-session ] [ sessions>> new-session ] [ drop ] 2tri ; @@ -87,23 +85,37 @@ M: session-saver dispose : save-session-after ( session -- ) add-always-destructor ; -: call-responder/session ( path responder session -- response ) - [ save-session-after ] [ session set ] bi +: existing-session ( path responder session -- response ) + [ session set ] [ save-session-after ] bi [ session-manager set ] [ responder>> call-responder ] bi ; -TUPLE: url-sessions < session-manager ; - -: ( responder -- responder' ) - url-sessions new-session-manager ; - : session-id-key "factorsessid" ; -: current-url-session ( responder -- session/f ) - >r request-params session-id-key swap at string>number - r> sessions>> get-session ; +: cookie-session-id ( -- id/f ) + request get session-id-key get-cookie + dup [ value>> string>number ] when ; -: add-session-id ( query -- query' ) - session get [ id>> session-id-key associate assoc-union ] when* ; +: post-session-id ( -- id/f ) + session-id-key request get post-data>> at string>number ; + +: request-session-id ( -- id/f ) + request get method>> { + { "GET" [ cookie-session-id ] } + { "HEAD" [ cookie-session-id ] } + { "POST" [ post-session-id ] } + } case ; + +: request-session ( responder -- session/f ) + >r request-session-id r> sessions>> get-session ; + +: ( id -- cookie ) + session-id-key ; + +: new-session ( path responder -- response ) + dup begin-session + [ existing-session ] + [ id>> number>string ] bi + put-cookie ; : session-form-field ( -- ) > number>string =value input/> ; -: new-url-session ( path responder -- response ) - [ drop f ] [ begin-session id>> session-id-key associate ] bi* - ; - -M: url-sessions call-responder ( path responder -- response ) - [ add-session-id ] add-link-hook +M: session-manager call-responder ( path responder -- response ) [ session-form-field ] add-form-hook - dup current-url-session [ - call-responder/session - ] [ - new-url-session - ] if* ; - -TUPLE: cookie-sessions < session-manager ; - -: ( responder -- responder' ) - cookie-sessions new-session-manager ; - -: current-cookie-session ( responder -- session/f ) - request get session-id-key get-cookie dup - [ value>> string>number swap sessions>> get-session ] - [ 2drop f ] if ; - -: ( id -- cookie ) - session-id-key ; - -: call-responder/new-session ( path responder -- response ) - dup begin-session - [ call-responder/session ] - [ id>> number>string ] bi - put-cookie ; - -M: cookie-sessions call-responder ( path responder -- response ) - dup current-cookie-session [ - call-responder/session - ] [ - call-responder/new-session - ] if* ; + dup request-session [ existing-session ] [ new-session ] if* ; diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 4fa8f55ca8..07b3e9c02d 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -8,6 +8,7 @@ http.server.actions http.server.components http.server.components.code http.server.templating.chloe +http.server.auth.login http.server.boilerplate http.server.validators http.server.forms ; @@ -240,8 +241,8 @@ TUPLE: pastebin < dispatcher ; "list" add-main-responder "feed.xml" add-responder [ ] "view-paste" add-responder - [ ] "$pastebin/list" "delete-paste" add-responder - [ ] "$pastebin/view-paste" "delete-annotation" add-responder + [ ] "$pastebin/list" "delete-paste" add-responder + [ ] "$pastebin/view-paste" "delete-annotation" add-responder [ ] "$pastebin/view-paste" add-responder [ now >>date ] "$pastebin/view-paste" "new-paste" add-responder [ now >>date ] "$pastebin/view-paste" "annotate" add-responder diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index bb4a4b9cd2..5c60b37f82 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -70,4 +70,5 @@ TUPLE: todo-list < dispatcher ; ctor "$todo-list/list" "delete" add-responder "todo" todo-template >>template + ] ;