Debugging asides and conversation scope

db4
Slava Pestov 2008-09-21 19:42:05 -05:00
parent 0a4a776d02
commit e9b30d2bbc
13 changed files with 160 additions and 90 deletions

View File

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

View File

@ -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
user ensure-table ;
state-classes ensure-tables ;
: start-expiring ( db params -- )
'[

View File

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

View File

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

View File

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

View File

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

View File

@ -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
[ description cset ] [ capabilities cset ] [ drop ] tri*
URL" $realm/login" >secure-url <redirect> ;
begin-conversation
[ description cset ] [ capabilities cset ] [ secure>> ] tri*
[
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

View File

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

View File

@ -11,18 +11,13 @@ furnace.sessions
furnace.redirection ;
IN: furnace.conversations
TUPLE: conversation < scope
session
method url post-data ;
TUPLE: conversation < scope session ;
: <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 [ dup session>> session get id>> = [ drop f ] unless ] when ;
dup [ conversation get-state ] when check-session ;
: 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*
set-conversation
empty-conversastion
[ add-conversation ]
[ set-conversation ] bi
] unless ;
: end-conversation ( -- )
conversation off
conversation-id off ;
: <conversation-redirect> ( url seq -- response )
begin-conversation
[ [ get ] keep cset ] each
: <continue-conversation> ( url -- response )
conversation-id get
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

View File

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

View File

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

View File

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

View File

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