Debugging asides and conversation scope

basis/furnace/actions/actions.factor

@@ -86,7 +86,7 @@ TUPLE: action rest authorize init display validate submit ;
         begin-conversation
         nested-forms-key param " " split harvest nested-forms cset
         form get form cset
-        <redirect>
+        <continue-conversation>
     ] [ <400> ] if*
     exit-with ;
 

basis/furnace/alloy/alloy.factor

@@ -3,6 +3,7 @@
 USING: kernel sequences db.tuples alarms calendar db fry
 furnace.db
 furnace.cache
+furnace.asides
 furnace.referrer
 furnace.sessions
 furnace.conversations
@@ -12,17 +13,17 @@ IN: furnace.alloy
 
 : <alloy> ( responder db params -- responder' )
     '[
+        <asides>
         <conversations>
         <sessions>
         _ _ <db-persistence>
         <check-form-submissions>
     ] call ;
 
-: state-classes { session conversation permit } ; inline
+: state-classes { session aside conversation permit user } ; inline
 
 : init-furnace-tables ( -- )
-    state-classes ensure-tables
+    state-classes ensure-tables ;
-    user ensure-table ;
 
 : start-expiring ( db params -- )
     '[

basis/furnace/asides/asides.factor

@@ -0,0 +1,111 @@
+! 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.sessions
+furnace.redirection ;
+IN: furnace.asides
+
+TUPLE: aside < server-state
+session method url post-data ;
+
+: <aside> ( id -- aside )
+    aside new-server-state ;
+
+aside "ASIDES" {
+    { "session" "SESSION" BIG-INTEGER +not-null+ }
+    { "method" "METHOD" { VARCHAR 10 } }
+    { "url" "URL" URL }
+    { "post-data" "POST_DATA" FACTOR-BLOB }
+} define-persistent
+
+: aside-id-key "__a" ;
+
+TUPLE: asides < server-state-manager ;
+
+: <asides> ( responder -- responder' )
+    asides new-server-state-manager ;
+
+SYMBOL: aside-id
+
+: get-aside ( id -- aside )
+    dup [ aside get-state ] when check-session ;
+
+: request-aside-id ( request -- id )
+    aside-id-key swap request-params at string>number ;
+
+: request-aside ( request -- aside )
+    request-aside-id get-aside ;
+
+: set-aside ( aside -- )
+    [ id>> aside-id set ] when* ;
+
+: init-asides ( asides -- )
+    asides set
+    request get request-aside-id
+    get-aside
+    set-aside ;
+
+M: asides call-responder*
+    [ init-asides ] [ asides set ] [ call-next-method ] tri ;
+
+: touch-aside ( aside -- )
+    asides get touch-state ;
+
+: begin-aside ( url -- )
+    f <aside>
+        swap >>url
+        session get id>> >>session
+        request get method>> >>method
+        request get post-data>> >>post-data
+    [ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
+
+: end-aside-post ( aside -- response )
+    [ url>> ] [ post-data>> ] bi
+    request [
+        clone
+            swap >>post-data
+            over >>url
+    ] change
+    [ url set ] [ path>> split-path ] bi
+    asides get responder>> call-responder ;
+
+\ end-aside-post DEBUG add-input-logging
+
+ERROR: end-aside-in-get-error ;
+
+: move-on ( id -- response )
+    post-request? [ end-aside-in-get-error ] unless
+    dup method>> {
+        { "GET" [ url>> <redirect> ] }
+        { "HEAD" [ url>> <redirect> ] }
+        { "POST" [ end-aside-post ] }
+    } case ;
+
+: end-aside ( default -- response )
+    aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
+
+M: asides link-attr ( tag -- )
+    drop
+    "aside" optional-attr {
+        { "none" [ aside-id off ] }
+        { "begin" [ url get begin-aside ] }
+        { "current" [ ] }
+        { f [ ] }
+    } case ;
+
+M: asides modify-query ( query asides -- query' )
+    drop
+    aside-id get [
+        aside-id-key associate assoc-union
+    ] when* ;
+
+M: asides modify-form ( asides -- )
+    drop
+    aside-id get
+    aside-id-key
+    hidden-form-field ;

basis/furnace/auth/features/deactivate-user/deactivate-user.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel assocs namespaces accessors db db.tuples urls
 http.server.dispatchers
-furnace.conversations
+furnace.asides
 furnace.actions
 furnace.auth
 furnace.auth.providers ;

basis/furnace/auth/features/edit-profile/edit-profile.factor

@@ -3,8 +3,8 @@
 USING: kernel accessors namespaces sequences assocs
 validators urls html.forms http.server.dispatchers
 furnace.auth
-furnace.actions
+furnace.asides
-furnace.conversations ;
+furnace.actions ;
 IN: furnace.auth.features.edit-profile
 
 : <edit-profile-action> ( -- action )

basis/furnace/auth/features/recover-password/recover-password.factor

@@ -19,7 +19,7 @@ SYMBOL: lost-password-from
         [ username>> "username" set-query-param ]
         [ ticket>> "ticket" set-query-param ]
         bi
-    adjust-url relative-to-request ;
+    adjust-url ;
 
 : password-email ( user -- email )
     <email>

basis/furnace/auth/login/login.factor

@@ -5,6 +5,7 @@ calendar validators urls logging html.forms
 http http.server http.server.dispatchers
 furnace
 furnace.auth
+furnace.asides
 furnace.actions
 furnace.sessions
 furnace.utilities
@@ -93,9 +94,15 @@ SYMBOL: capabilities
         [ logout ] >>submit ;
 
 M: login-realm login-required* ( description capabilities login -- response )
-    begin-aside
+    begin-conversation
-    [ description cset ] [ capabilities cset ] [ drop ] tri*
+    [ description cset ] [ capabilities cset ] [ secure>> ] tri*
-    URL" $realm/login" >secure-url <redirect> ;
+    [
+        url get >secure-url begin-aside
+        URL" $realm/login" >secure-url <continue-conversation>
+    ] [
+        url get begin-aside
+        URL" $realm/login" <continue-conversation>
+    ] if ;
 
 : <login-realm> ( responder name -- auth )
     login-realm new-realm

basis/furnace/chloe-tags/chloe-tags.factor

@@ -37,7 +37,7 @@ IN: furnace.chloe-tags
         <url>
             swap parse-query-attr >>query
             -rot a-url-path >>path
-        adjust-url relative-to-request
+        adjust-url
     ] if ;
 
 : compile-a-url ( tag -- )

basis/furnace/conversations/conversations.factor

@@ -11,18 +11,13 @@ furnace.sessions
 furnace.redirection ;
 IN: furnace.conversations
 
-TUPLE: conversation < scope
+TUPLE: conversation < scope session ;
-session
-method url post-data ;
 
-: <conversation> ( id -- aside )
+: <conversation> ( id -- conversation )
     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 "__c" ;
@@ -46,8 +41,7 @@ SYMBOL: conversation-id
     conversation get scope-change ; inline
 
 : get-conversation ( id -- conversation )
-    dup [ conversation get-state ] when
+    dup [ conversation get-state ] when check-session ;
-    dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
 
 : request-conversation-id ( request -- id )
     conversation-id-key swap request-params at string>number ;
@@ -88,22 +82,21 @@ M: conversations call-responder*
 : add-conversation ( conversation -- )
     [ touch-conversation ] [ insert-tuple ] bi ;
 
-: begin-conversation* ( -- conversation )
-    empty-conversastion dup add-conversation ;
-
 : begin-conversation ( -- )
     conversation get [
-        begin-conversation*
+        empty-conversastion
-        set-conversation
+        [ add-conversation ]
+        [ set-conversation ] bi
     ] unless ;
 
 : end-conversation ( -- )
     conversation off
     conversation-id off ;
 
-: <conversation-redirect> ( url seq -- response )
+: <continue-conversation> ( url -- response )
-    begin-conversation
+    conversation-id get
-    [ [ get ] keep cset ] each
+    conversation-id-key
+    set-query-param
     <redirect> ;
 
 : restore-conversation ( seq -- )
@@ -114,64 +107,6 @@ M: conversations call-responder*
         bi
     ] [ 2drop ] if ;
 
-: begin-aside ( -- )
-    begin-conversation
-    conversation get
-        request get
-        [ method>> >>method ]
-        [ url>> >>url ]
-        [ post-data>> >>post-data ]
-        tri
-    touch-conversation ;
-
-: end-aside-post ( aside -- response )
-    request [
-        clone
-            over post-data>> >>post-data
-            over url>> >>url
-    ] change
-    [ url>> url set ]
-    [ url>> path>> split-path ] bi
-    conversations get responder>> call-responder ;
-
-\ end-aside-post DEBUG add-input-logging
-
-ERROR: end-aside-in-get-error ;
-
-: move-on ( id -- response )
-    post-request? [ end-aside-in-get-error ] unless
-    dup method>> {
-        { "GET" [ url>> <redirect> ] }
-        { "HEAD" [ url>> <redirect> ] }
-        { "POST" [ end-aside-post ] }
-    } case ;
-
-: get-aside ( id -- conversation )
-    get-conversation dup [ dup method>> [ drop f ] unless ] when ;
-
-: end-aside* ( url id -- response )
-    get-aside [ move-on ] [ <redirect> ] ?if ;
-
-: end-aside ( default -- response )
-    conversation-id get
-    end-conversation
-    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

basis/furnace/furnace.factor

@@ -37,6 +37,10 @@ GENERIC: modify-query ( query responder -- query' )
 
 M: object modify-query drop ;
 
+GENERIC: modify-redirect-query ( query responder -- query' )
+
+M: object modify-redirect-query drop ;
+
 GENERIC: adjust-url ( url -- url' )
 
 M: url adjust-url
@@ -47,6 +51,14 @@ M: url adjust-url
 
 M: string adjust-url ;
 
+GENERIC: adjust-redirect-url ( url -- url' )
+
+M: url adjust-redirect-url
+    adjust-url
+    [ [ modify-redirect-query ] each-responder ] change-query ;
+
+M: string adjust-redirect-url ;
+
 GENERIC: link-attr ( tag responder -- )
 
 M: object link-attr 2drop ;

basis/furnace/redirection/redirection.factor

@@ -7,7 +7,7 @@ http.server.filters furnace ;
 IN: furnace.redirection
 
 : <redirect> ( url -- response )
-    adjust-url request get method>> {
+    adjust-redirect-url request get method>> {
         { "GET" [ <temporary-redirect> ] }
         { "HEAD" [ <temporary-redirect> ] }
         { "POST" [ <permanent-redirect> ] }

basis/furnace/sessions/sessions.factor

@@ -107,3 +107,7 @@ M: sessions call-responder* ( path responder -- response )
     sessions set
     request-session [ begin-session ] unless*
     existing-session put-session-cookie ;
+
+: check-session ( state/f -- state/f )
+    dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
+

basis/furnace/syndication/syndication.factor

@@ -32,7 +32,7 @@ M: object >entry
 : process-entries ( seq -- seq' )
     20 short head-slice [
         >entry clone
-        [ adjust-url relative-to-request ] change-url
+        [ adjust-url ] change-url
     ] map ;
 
 : <feed-content> ( body -- response )
@@ -46,7 +46,7 @@ TUPLE: feed-action < action title url entries ;
             feed new
                 _
                 [ title>> call >>title ]
-                [ url>> call adjust-url relative-to-request >>url ]
+                [ url>> call adjust-url >>url ]
                 [ entries>> call process-entries >>entries ]
                 tri
             <feed-content>