Working on conversation scope to supercede asides and flash scopes
parent
34c0cf6111
commit
bf47ff4007
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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 ;
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue