diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 6448fcdf07..ad8a36cca5 100755 --- a/extra/furnace/actions/actions.factor +++ b/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 ( -- * ) - 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 } - ] [ <400> ] if* + swap { form nested-forms } append + ] [ 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 ; diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index 0c21c9f18d..4fae10c30d 100755 --- a/extra/furnace/auth/auth.factor +++ b/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 ; diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 9246780a94..f2ac81c066 100755 --- a/extra/furnace/auth/login/login.factor +++ b/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 ; : ( -- action ) diff --git a/extra/furnace/conversations/conversations.factor b/extra/furnace/conversations/conversations.factor new file mode 100644 index 0000000000..cbc4e4b233 --- /dev/null +++ b/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 ; + +: ( 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 ; + +: ( 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 ; + +: ( url seq -- response ) + begin-conversation + [ [ get ] keep cset ] each + ; + +: 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>> ] } + { "HEAD" [ url>> ] } + { "POST" [ end-aside-post ] } + } case + ] [ ] ?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 ; diff --git a/extra/furnace/scopes/scopes.factor b/extra/furnace/scopes/scopes.factor new file mode 100644 index 0000000000..daad0dcf91 --- /dev/null +++ b/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 + +M: scope-saver dispose + [ manager>> ] [ scope>> ] bi + dup changed?>> [ + [ swap touch-state ] [ update-tuple ] bi + ] [ 2drop ] if ; + +: save-scope-after ( scope manager -- ) + &dispose drop ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 31711f54e9..3aafadaf68 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/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 ; : ( 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 - 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 - -M: session-saver dispose - session>> dup changed?>> [ - [ touch-session ] [ update-tuple ] bi - ] [ drop ] if ; - : save-session-after ( session -- ) - &dispose drop ; + sessions get &dispose drop ; : existing-session ( path session -- response ) [ session set ] [ save-session-after ] bi