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

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

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

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 ;
IN: http.server.auth.basic
TUPLE: basic-auth responder realm provider ;
TUPLE: basic-auth < filter-responder realm provider ;
C: <basic-auth> basic-auth
@ -38,4 +38,4 @@ C: <basic-auth> 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 ;

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

@ -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> protected
M: protected init-session* responder>> init-session* ;
: show-login-page ( -- response )
begin-flow
"$login/login" f <temporary-redirect> ;
@ -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?

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

@ -9,12 +9,10 @@ http.server.sessions
http.server.templating ;
IN: http.server.boilerplate
TUPLE: boilerplate responder template ;
TUPLE: boilerplate < filter-responder template ;
: <boilerplate> 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

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 ;
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> db-persistence
@ -15,4 +13,4 @@ C: <db-persistence> 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 ;

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 ;
IN: http.server.flows
TUPLE: flows responder ;
TUPLE: flows < filter-responder ;
C: <flows> 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 ;

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

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

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

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

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
] with-destructors ;
: cookie-responder-mock-test
: session-manager-mock-test
[
<request>
"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> url-sessions? ] unit-test
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
[ ] [
<foo> <url-sessions>
<foo> <session-manager>
sessions-in-db >>sessions
session-manager set
] unit-test
@ -113,26 +107,7 @@ M: foo call-responder
] unit-test
[ ] [
[
<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>
<foo> <session-manager>
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
[
{ } <exiting-action> <cookie-sessions>
{ } <exiting-action> <session-manager>
sessions-in-db >>sessions
call-responder
] 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.
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 ;
: <session-manager> ( 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 -- )
<session-saver> 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 ;
: <url-sessions> ( 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 ;
: <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 ( -- )
<input
@ -112,41 +124,6 @@ TUPLE: url-sessions < session-manager ;
session get id>> number>string =value
input/> ;
: new-url-session ( 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
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 ;
: <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* ;
dup request-session [ existing-session ] [ new-session ] if* ;

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

@ -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 ;
<paste-list-action> "list" add-main-responder
<feed-action> "feed.xml" add-responder
<paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
[ <paste> ] "$pastebin/list" <delete-paste-action> "delete-paste" add-responder
[ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> "delete-annotation" add-responder
[ <paste> ] "$pastebin/list" <delete-paste-action> <protected> "delete-paste" 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
<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

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
<boilerplate>
"todo" todo-template >>template
<protected>
] ;