Working on conversation scope to supercede asides and flash scopes

db4
Slava Pestov 2008-07-09 19:48:40 -05:00
parent 34c0cf6111
commit bf47ff4007
6 changed files with 209 additions and 38 deletions

View File

@ -75,12 +75,11 @@ TUPLE: action rest authorize init display validate submit ;
revalidate-url-key param
dup [ >url [ same-host? ] keep and ] when ;
: validation-failed ( -- * )
post-request? revalidate-url and
[
: validation-failed ( flashed -- * )
post-request? revalidate-url and dup [
nested-forms-key param " " split harvest nested-forms set
{ form nested-forms } <flash-redirect>
] [ <400> ] if*
swap { form nested-forms } append <flash-redirect>
] [ 2drop <400> ] if
exit-with ;
: handle-post ( action -- response )
@ -113,7 +112,7 @@ M: action modify-form
drop url get revalidate-url-key hidden-form-field ;
: check-validation ( -- )
validation-failed? [ validation-failed ] when ;
validation-failed? [ { } validation-failed ] when ;
: validate-params ( validators -- )
params get swap validate-values check-validation ;

View File

@ -152,7 +152,7 @@ M: protected call-responder* ( path responder -- response )
: password-mismatch ( -- * )
"passwords do not match" validation-error
validation-failed ;
{ } validation-failed ;
: same-password-twice ( -- )
"new-password" value "verify-password" value =
@ -160,4 +160,4 @@ M: protected call-responder* ( path responder -- response )
: user-exists ( -- * )
"username taken" validation-error
validation-failed ;
{ } validation-failed ;

View File

@ -65,7 +65,7 @@ SYMBOL: capabilities
: login-failed ( -- * )
"invalid username or password" validation-error
validation-failed ;
flashed-variables validation-failed ;
: <login-action> ( -- action )
<page-action>

View File

@ -0,0 +1,151 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel sequences accessors hashtables
urls db.types db.tuples math.parser fry logging combinators
html.templates.chloe.syntax
http http.server http.server.filters http.server.redirection
furnace
furnace.cache
furnace.scopes
furnace.sessions
furnace.redirection ;
IN: furnace.conversations
TUPLE: conversation < scope
session
method url post-data ;
: <conversation> ( id -- aside )
conversation new-server-state ;
conversation "CONVERSATIONS" {
{ "session" "SESSION" BIG-INTEGER +not-null+ }
{ "method" "METHOD" { VARCHAR 10 } }
{ "url" "URL" URL }
{ "post-data" "POST_DATA" FACTOR-BLOB }
} define-persistent
: conversation-id-key "__f" ;
TUPLE: conversations < server-state-manager ;
: <conversations> ( responder -- responder' )
conversations new-server-state-manager ;
SYMBOL: conversation
SYMBOL: conversation-id
: cget ( key -- value )
conversation get scope-get ;
: cset ( value key -- )
conversation get scope-set ;
: cchange ( key quot -- )
conversation get scope-change ; inline
: get-conversation ( id -- conversation )
dup [ conversation get-state ] when
dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
: request-conversation-id ( request -- id )
conversation-id-key swap request-params at string>number ;
: request-conversation ( request -- conversation )
request-conversation-id get-conversation ;
: init-conversations ( -- )
request get request-conversation-id
[ conversation-id set ]
[ get-conversation conversation set ]
bi ;
M: conversations call-responder*
init-conversations
[ conversations set ] [ call-next-method ] bi ;
: empty-conversastion ( -- conversation )
conversation empty-scope
session get id>> >>session ;
: add-conversation ( conversation -- id )
[ conversations get touch-state ] [ insert-tuple ] [ id>> ] tri ;
: begin-conversation* ( -- id )
empty-conversastion add-conversation ;
: begin-conversation ( -- )
conversation-id [ [ begin-conversation* ] unless* ] change ;
: <conversation-redirect> ( url seq -- response )
begin-conversation
[ [ get ] keep cset ] each
<redirect> ;
: restore-conversation ( seq -- )
conversation get dup [
namespace>>
[ '[ , key? ] filter ]
[ '[ [ , at ] keep set ] each ]
bi
] [ 2drop ] if ;
: begin-aside* ( -- id )
empty-conversastion
request get
[ method>> >>method ]
[ url>> >>url ]
[ post-data>> >>post-data ]
tri
add-conversation ;
: begin-aside ( -- )
begin-aside* conversation-id set ;
: end-aside-post ( aside -- response )
request [
clone
over post-data>> >>post-data
over url>> >>url
] change
url>> path>> split-path
conversations get responder>> call-responder ;
\ end-aside-post DEBUG add-input-logging
ERROR: end-aside-in-get-error ;
: end-aside* ( url id -- response )
post-request? [ end-aside-in-get-error ] unless
get-conversation [
dup method>> {
{ "GET" [ url>> <redirect> ] }
{ "HEAD" [ url>> <redirect> ] }
{ "POST" [ end-aside-post ] }
} case
] [ <redirect> ] ?if ;
: end-aside ( default -- response )
conversation-id [ f ] change end-aside* ;
M: conversations link-attr ( tag -- )
drop
"aside" optional-attr {
{ "none" [ conversation-id off ] }
{ "begin" [ begin-aside ] }
{ "current" [ ] }
{ f [ ] }
} case ;
M: conversations modify-query ( query conversations -- query' )
drop
conversation-id get [
conversation-id-key associate assoc-union
] when* ;
M: conversations modify-form ( conversations -- )
drop
conversation-id get
conversation-id-key
hidden-form-field ;

View File

@ -0,0 +1,42 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors assocs destructors
db.tuples db.types furnace.cache ;
IN: furnace.scopes
TUPLE: scope < server-state namespace changed? ;
: empty-scope ( class -- scope )
f swap new-server-state
H{ } clone >>namespace ; inline
scope f
{
{ "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
} define-persistent
: scope-changed ( scope -- )
t >>changed? drop ;
: scope-get ( key scope -- value )
dup [ namespace>> at ] [ 2drop f ] if ;
: scope-set ( value key scope -- )
[ namespace>> set-at ] [ scope-changed ] bi ;
: scope-change ( key quot scope -- )
[ namespace>> swap change-at ] [ scope-changed ] bi ; inline
! Destructor
TUPLE: scope-saver scope manager ;
C: <scope-saver> scope-saver
M: scope-saver dispose
[ manager>> ] [ scope>> ] bi
dup changed?>> [
[ swap touch-state ] [ update-tuple ] bi
] [ 2drop ] if ;
: save-scope-after ( scope manager -- )
<scope-saver> &dispose drop ;

View File

@ -7,17 +7,16 @@ io.servers.connection
db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements
furnace furnace.cache ;
furnace furnace.cache furnace.scopes ;
IN: furnace.sessions
TUPLE: session < server-state namespace user-agent client changed? ;
TUPLE: session < scope user-agent client ;
: <session> ( id -- session )
session new-server-state ;
session "SESSIONS"
{
{ "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
{ "user-agent" "USER_AGENT" TEXT +not-null+ }
{ "client" "CLIENT" TEXT +not-null+ }
} define-persistent
@ -39,23 +38,14 @@ TUPLE: sessions < server-state-manager domain verify? ;
sessions new-server-state-manager
t >>verify? ;
: (session-changed) ( session -- )
t >>changed? drop ;
: session-changed ( -- )
session get (session-changed) ;
session get scope-changed ;
: sget ( key -- value )
session get namespace>> at ;
: sget ( key -- value ) session get scope-get ;
: sset ( value key -- )
session get
[ namespace>> set-at ] [ (session-changed) ] bi ;
: sset ( value key -- ) session get scope-set ;
: schange ( key quot -- )
session get
[ namespace>> swap change-at ] keep
(session-changed) ; inline
: schange ( key quot -- ) session get scope-change ; inline
: init-session ( session -- )
session [ sessions get init-session* ] with-variable ;
@ -70,8 +60,7 @@ TUPLE: sessions < server-state-manager domain verify? ;
} 0|| ;
: empty-session ( -- session )
f <session>
H{ } clone >>namespace
session empty-scope
remote-host >>client
user-agent >>user-agent
dup touch-session ;
@ -79,18 +68,8 @@ TUPLE: sessions < server-state-manager domain verify? ;
: begin-session ( -- session )
empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
! Destructor
TUPLE: session-saver session ;
C: <session-saver> session-saver
M: session-saver dispose
session>> dup changed?>> [
[ touch-session ] [ update-tuple ] bi
] [ drop ] if ;
: save-session-after ( session -- )
<session-saver> &dispose drop ;
sessions get <scope-saver> &dispose drop ;
: existing-session ( path session -- response )
[ session set ] [ save-session-after ] bi