Debugging asides and conversation scope
parent
0a4a776d02
commit
e9b30d2bbc
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 -- )
|
||||
'[
|
||||
|
|
|
@ -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 ;
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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> ] }
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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>
|
||||
|
|
Loading…
Reference in New Issue