Working on conversation scope to supercede asides and flash scopes

extra/furnace/actions/actions.factor

@@ -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 ( -- * )
+: validation-failed ( flashed -- * )
-    post-request? revalidate-url and
+    post-request? revalidate-url and dup [
-    [
         nested-forms-key param " " split harvest nested-forms set
-        { form nested-forms } <flash-redirect>
+        swap { form nested-forms } append <flash-redirect>
-    ] [ <400> ] if*
+    ] [ 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 ;

extra/furnace/auth/auth.factor

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

extra/furnace/auth/login/login.factor

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

extra/furnace/conversations/conversations.factor

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

extra/furnace/scopes/scopes.factor

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

extra/furnace/sessions/sessions.factor

@@ -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 )
+: sget ( key -- value ) session get scope-get ;
-    session get namespace>> at ;
 
-: sset ( value key -- )
+: sset ( value key -- ) session get scope-set ;
-    session get
-    [ namespace>> set-at ] [ (session-changed) ] bi ;
 
-: schange ( key quot -- )
+: schange ( key quot -- ) session get scope-change ; inline
-    session get
-    [ namespace>> swap change-at ] keep
-    (session-changed) ; 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>
+    session empty-scope
-        H{ } clone >>namespace
         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