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

Merge URL and cookie session managers, clean up some code

db4
Slava Pestov 2008-04-26 18:56:51 -05:00
parent 6ee115901a
commit 7d16edcc79
13 changed files with 80 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

12
extra/http/server/auth/auth.factor
View File

@ -1,7 +1,9 @@
! Copyright (c) 2008 Slava Pestov ! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: http.server.sessions accessors USING: accessors assocs namespaces kernel
http.server.auth.providers assocs namespaces kernel ; http.server
http.server.sessions
http.server.auth.providers ;
IN: http.server.auth IN: http.server.auth
SYMBOL: logged-in-user SYMBOL: logged-in-user
@ -11,6 +13,12 @@ GENERIC: init-user-profile ( responder -- )
M: object init-user-profile drop ; 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>> ; : uid ( -- string ) logged-in-user sget username>> ;
: profile ( -- assoc ) logged-in-user sget profile>> ; : profile ( -- assoc ) logged-in-user sget profile>> ;

4
extra/http/server/auth/basic/basic.factor
View File

@ -6,7 +6,7 @@ http.server.auth.providers http.server.auth.providers.null
http sequences ; http sequences ;
IN: http.server.auth.basic IN: http.server.auth.basic
TUPLE: basic-auth responder realm provider ; TUPLE: basic-auth < filter-responder realm provider ;
C: <basic-auth> basic-auth C: <basic-auth> basic-auth
@ -38,4 +38,4 @@ C: <basic-auth> basic-auth
M: basic-auth call-responder ( request path responder -- response ) M: basic-auth call-responder ( request path responder -- response )
pick over logged-in? pick over logged-in?
[ responder>> call-responder ] [ 2nip realm>> <401> ] if ; [ call-next-method ] [ 2nip realm>> <401> ] if ;

11
extra/http/server/auth/login/login.factor
View File

@ -138,7 +138,7 @@ SYMBOL: user-exists?
successful-login successful-login
login get default>> responder>> init-user-profile login get init-user-profile
] >>submit ] >>submit
] ; ] ;
@ -177,7 +177,8 @@ SYMBOL: user-exists?
logged-in-user sget logged-in-user sget
"password" value empty? [ { "password" "new-password" "verify-password" }
[ value empty? ] all? [
same-password-twice same-password-twice
"password" value uid users check-login "password" value uid users check-login
@ -335,12 +336,10 @@ SYMBOL: lost-password-from
! ! ! Authentication logic ! ! ! Authentication logic
TUPLE: protected responder ; TUPLE: protected < filter-responder ;
C: <protected> protected C: <protected> protected
M: protected init-session* responder>> init-session* ;
: show-login-page ( -- response ) : show-login-page ( -- response )
begin-flow begin-flow
"$login/login" f <temporary-redirect> ; "$login/login" f <temporary-redirect> ;
@ -348,7 +347,7 @@ M: protected init-session* responder>> init-session* ;
M: protected call-responder ( path responder -- response ) M: protected call-responder ( path responder -- response )
logged-in-user sget dup [ logged-in-user sget dup [
save-user-after save-user-after
responder>> call-responder call-next-method
] [ ] [
3drop 3drop
request get method>> { "GET" "HEAD" } member? request get method>> { "GET" "HEAD" } member?

6
extra/http/server/boilerplate/boilerplate.factor
View File

@ -9,12 +9,10 @@ http.server.sessions
http.server.templating ; http.server.templating ;
IN: http.server.boilerplate IN: http.server.boilerplate
TUPLE: boilerplate responder template ; TUPLE: boilerplate < filter-responder template ;
: <boilerplate> f boilerplate boa ; : <boilerplate> f boilerplate boa ;
M: boilerplate init-session* responder>> init-session* ;
SYMBOL: title SYMBOL: title
: set-title ( string -- ) : set-title ( string -- )
@ -71,7 +69,7 @@ M: f call-template* drop call-next-template ;
] with-scope ; inline ] with-scope ; inline
M: boilerplate call-responder M: boilerplate call-responder
tuck responder>> call-responder tuck call-next-method
dup "content-type" header "text/html" = [ dup "content-type" header "text/html" = [
clone swap template>> clone swap template>>
[ [ with-boilerplate ] 2curry ] curry change-body [ [ with-boilerplate ] 2curry ] curry change-body

6
extra/http/server/db/db.factor
View File

@ -4,9 +4,7 @@ USING: db http.server http.server.sessions kernel accessors
continuations namespaces destructors ; continuations namespaces destructors ;
IN: http.server.db IN: http.server.db
TUPLE: db-persistence responder db params ; TUPLE: db-persistence < filter-responder db params ;
M: db-persistence init-session* responder>> init-session* ;
C: <db-persistence> db-persistence C: <db-persistence> db-persistence
@ -15,4 +13,4 @@ C: <db-persistence> db-persistence
[ db set ] [ add-always-destructor ] bi ; [ db set ] [ add-always-destructor ] bi ;
M: db-persistence call-responder M: db-persistence call-responder
[ connect-db ] [ responder>> call-responder ] bi ; [ connect-db ] [ call-next-method ] bi ;

6
extra/http/server/flows/flows.factor
View File

@ -5,7 +5,7 @@ assocs assocs.lib hashtables math.parser
html.elements http http.server http.server.sessions ; html.elements http http.server http.server.sessions ;
IN: http.server.flows IN: http.server.flows
TUPLE: flows responder ; TUPLE: flows < filter-responder ;
C: <flows> flows C: <flows> flows
@ -43,8 +43,8 @@ M: flows call-responder
[ add-flow-id ] add-link-hook [ add-flow-id ] add-link-hook
[ flow-form-field ] add-form-hook [ flow-form-field ] add-form-hook
flow-id-key request-params at flow-id set flow-id-key request-params at flow-id set
responder>> call-responder ; call-next-method ;
M: flows init-session* M: flows init-session*
H{ } clone flows sset H{ } clone flows sset
responder>> init-session* ; call-next-method ;

2
extra/http/server/server-tests.factor
View File

@ -11,6 +11,8 @@ IN: http.server.tests
{ { "a" "b" } } >>query { { "a" "b" } } >>query
request set 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/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?a=b" ] [ "baz" f derive-url ] unit-test
[ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test [ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test

5
extra/http/server/server.factor
View File

@ -181,6 +181,11 @@ M: vhost-dispatcher call-responder ( path dispatcher -- response )
[ drop "" add-responder drop ] [ drop "" add-responder drop ]
[ 2drop ] 3tri ; [ 2drop ] 3tri ;
TUPLE: filter-responder responder ;
M: filter-responder call-responder
responder>> call-responder ;
SYMBOL: main-responder SYMBOL: main-responder
main-responder global main-responder global

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

@ -32,7 +32,7 @@ M: foo call-responder
[ write-response-body drop ] with-string-writer [ write-response-body drop ] with-string-writer
] with-destructors ; ] with-destructors ;
: cookie-responder-mock-test : session-manager-mock-test
[ [
<request> <request>
"GET" >>method "GET" >>method
@ -58,9 +58,6 @@ M: foo call-responder
[ [
empty-session empty-session
123 >>id session set 123 >>id session set
session-changed? off
[ H{ { "factorsessid" 123 } } ] [ H{ } add-session-id ] unit-test
[ ] [ 3 "x" sset ] unit-test [ ] [ 3 "x" sset ] unit-test
@ -70,14 +67,11 @@ M: foo call-responder
[ 4 ] [ "x" sget sq ] unit-test [ 4 ] [ "x" sget sq ] unit-test
[ t ] [ session-changed? get ] unit-test [ t ] [ session get changed?>> ] unit-test
] with-scope ] with-scope
[ t ] [ f <url-sessions> url-sessions? ] unit-test
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
[ ] [ [ ] [
<foo> <url-sessions> <foo> <session-manager>
sessions-in-db >>sessions sessions-in-db >>sessions
session-manager set session-manager set
] unit-test ] unit-test
@ -113,26 +107,7 @@ M: foo call-responder
] unit-test ] unit-test
[ ] [ [ ] [
[ <foo> <session-manager>
<request>
"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
[ ] [
<foo> <cookie-sessions>
sessions-in-db >>sessions sessions-in-db >>sessions
session-manager set session-manager set
] unit-test ] unit-test
@ -150,9 +125,9 @@ M: foo call-responder
[ ] [ response get cookies>> "cookies" set ] unit-test [ ] [ response get cookies>> "cookies" set ] unit-test
[ "2" ] [ cookie-responder-mock-test ] unit-test [ "2" ] [ session-manager-mock-test ] unit-test
[ "3" ] [ cookie-responder-mock-test ] unit-test [ "3" ] [ session-manager-mock-test ] unit-test
[ "4" ] [ cookie-responder-mock-test ] unit-test [ "4" ] [ session-manager-mock-test ] unit-test
[ [
[ ] [ [ ] [
@ -163,7 +138,7 @@ M: foo call-responder
request set request set
[ [
{ } <exiting-action> <cookie-sessions> { } <exiting-action> <session-manager>
sessions-in-db >>sessions sessions-in-db >>sessions
call-responder call-responder
] with-destructors response set ] with-destructors response set

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math.parser namespaces random USING: assocs kernel math.parser namespaces random
accessors quotations hashtables sequences continuations accessors quotations hashtables sequences continuations
fry calendar destructors fry calendar combinators destructors
http http
http.server http.server
http.server.sessions.storage http.server.sessions.storage
@ -22,12 +22,12 @@ M: object init-session* drop ;
M: dispatcher init-session* default>> init-session* ; 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' ) TUPLE: session-manager < filter-responder sessions ;
new
null-sessions >>sessions : <session-manager> ( responder -- responder' )
swap >>responder ; inline null-sessions session-manager boa ;
: (session-changed) ( session -- ) : (session-changed) ( session -- )
t >>changed? drop ; t >>changed? drop ;
@ -49,8 +49,6 @@ TUPLE: session-manager responder sessions ;
: sessions session-manager get sessions>> ; : sessions session-manager get sessions>> ;
: managed-responder session-manager get responder>> ;
: init-session ( session managed -- ) : init-session ( session managed -- )
>r session r> '[ , init-session* ] with-variable ; >r session r> '[ , init-session* ] with-variable ;
@ -69,7 +67,7 @@ TUPLE: session-manager responder sessions ;
: begin-session ( responder -- session ) : begin-session ( responder -- session )
>r empty-session r> >r empty-session r>
[ responder>> init-session ] [ init-session ]
[ sessions>> new-session ] [ sessions>> new-session ]
[ drop ] [ drop ]
2tri ; 2tri ;
@ -87,23 +85,37 @@ M: session-saver dispose
: save-session-after ( session -- ) : save-session-after ( session -- )
<session-saver> add-always-destructor ; <session-saver> add-always-destructor ;
: call-responder/session ( path responder session -- response ) : existing-session ( path responder session -- response )
[ save-session-after ] [ session set ] bi [ session set ] [ save-session-after ] bi
[ session-manager set ] [ responder>> call-responder ] bi ; [ session-manager set ] [ responder>> call-responder ] bi ;
TUPLE: url-sessions < session-manager ;
: <url-sessions> ( responder -- responder' )
url-sessions new-session-manager ;
: session-id-key "factorsessid" ; : session-id-key "factorsessid" ;
: current-url-session ( responder -- session/f ) : cookie-session-id ( -- id/f )
>r request-params session-id-key swap at string>number request get session-id-key get-cookie
r> sessions>> get-session ; dup [ value>> string>number ] when ;
: add-session-id ( query -- query' ) : post-session-id ( -- id/f )
session get [ id>> session-id-key associate assoc-union ] when* ; 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 ;
: <session-cookie> ( id -- cookie )
session-id-key <cookie> ;
: new-session ( path responder -- response )
dup begin-session
[ existing-session ]
[ id>> number>string <session-cookie> ] bi
put-cookie ;
: session-form-field ( -- ) : session-form-field ( -- )
<input <input
@ -112,41 +124,6 @@ TUPLE: url-sessions < session-manager ;
session get id>> number>string =value session get id>> number>string =value
input/> ; input/> ;
: new-url-session ( path responder -- response ) M: session-manager call-responder ( path responder -- response )
[ drop f ] [ begin-session id>> session-id-key associate ] bi*
<temporary-redirect> ;
M: url-sessions call-responder ( path responder -- response )
[ add-session-id ] add-link-hook
[ session-form-field ] add-form-hook [ session-form-field ] add-form-hook
dup current-url-session [ dup request-session [ existing-session ] [ new-session ] if* ;
call-responder/session
] [
new-url-session
] if* ;
TUPLE: cookie-sessions < session-manager ;
: <cookie-sessions> ( 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 ;
: <session-cookie> ( id -- cookie )
session-id-key <cookie> ;
: call-responder/new-session ( path responder -- response )
dup begin-session
[ call-responder/session ]
[ id>> number>string <session-cookie> ] bi
put-cookie ;
M: cookie-sessions call-responder ( path responder -- response )
dup current-cookie-session [
call-responder/session
] [
call-responder/new-session
] if* ;

5
extra/webapps/pastebin/pastebin.factor
View File

@ -8,6 +8,7 @@ http.server.actions
http.server.components http.server.components
http.server.components.code http.server.components.code
http.server.templating.chloe http.server.templating.chloe
http.server.auth.login
http.server.boilerplate http.server.boilerplate
http.server.validators http.server.validators
http.server.forms ; http.server.forms ;
@ -240,8 +241,8 @@ TUPLE: pastebin < dispatcher ;
<paste-list-action> "list" add-main-responder <paste-list-action> "list" add-main-responder
<feed-action> "feed.xml" add-responder <feed-action> "feed.xml" add-responder
<paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder <paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
[ <paste> ] "$pastebin/list" <delete-paste-action> "delete-paste" add-responder [ <paste> ] "$pastebin/list" <delete-paste-action> <protected> "delete-paste" add-responder
[ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> "delete-annotation" add-responder [ <annotation> ] "$pastebin/view-paste" <protected> <delete-annotation-action> "delete-annotation" add-responder
<paste-form> [ <paste> ] <view-paste-action> "$pastebin/view-paste" add-responder <paste-form> [ <paste> ] <view-paste-action> "$pastebin/view-paste" add-responder
<new-paste-form> [ <paste> now >>date ] "$pastebin/view-paste" <new-paste-action> "new-paste" add-responder <new-paste-form> [ <paste> now >>date ] "$pastebin/view-paste" <new-paste-action> "new-paste" add-responder
<new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder <new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder

1
extra/webapps/todo/todo.factor
View File

@ -70,4 +70,5 @@ TUPLE: todo-list < dispatcher ;
ctor "$todo-list/list" <delete-action> "delete" add-responder ctor "$todo-list/list" <delete-action> "delete" add-responder
<boilerplate> <boilerplate>
"todo" todo-template >>template "todo" todo-template >>template
<protected>
] ; ] ;