Implement flash scopes, improved validation and login page, improved http-post

extra/furnace/actions/actions.factor

@@ -2,13 +2,15 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors sequences kernel assocs combinators
 validators http hashtables namespaces fry continuations locals
-io arrays math boxes
+io arrays math boxes splitting urls
 xml.entities
 http.server
 http.server.responses
 furnace
+furnace.flash
 html.elements
 html.components
+html.components
 html.templates.chloe
 html.templates.chloe.syntax ;
 IN: furnace.actions
@@ -39,48 +41,68 @@ TUPLE: action rest-param init display validate submit ;
 : <action> ( -- action )
     action new-action ;
 
+: flashed-variables ( -- seq )
+    { validation-messages named-validation-messages } ;
+
 : handle-get ( action -- response )
-    blank-values
+    '[
-    [ init>> call ]
+        ,
-    [ display>> call ]
+        [ init>> call ]
-    bi ;
+        [ drop flashed-variables restore-flash ]
+        [ display>> call ]
+        tri
+    ] with-exit-continuation ;
 
 : validation-failed ( -- * )
-    request get method>> "POST" =
+    request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
-    [ action get display>> call ] [ <400> ] if exit-with ;
 
-: handle-post ( action -- response )
+: (handle-post) ( action -- response )
-    init-validation
+    [ validate>> call ] [ submit>> call ] bi ;
-    blank-values
-    [ validate>> call ]
-    [ submit>> call ] bi ;
-
-: handle-rest-param ( arg -- )
-    dup length 1 > action get rest-param>> not or
-    [ <404> exit-with ] [
-        action get rest-param>> associate rest-param set
-    ] if ;
-
-M: action call-responder* ( path action -- response )
-    dup action set
-    '[
-        , dup empty? [ drop ] [ handle-rest-param ] if
-
-        init-validation
-        ,
-        request get
-        [ request-params rest-param get assoc-union params set ]
-        [ method>> ] bi
-        {
-            { "GET" [ handle-get ] }
-            { "HEAD" [ handle-get ] }
-            { "POST" [ handle-post ] }
-        } case
-    ] with-exit-continuation ;
 
 : param ( name -- value )
     params get at ;
 
+: revalidate-url-key "__u" ;
+
+: check-url ( url -- ? )
+    request get url>>
+    [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
+
+: revalidate-url ( -- url/f )
+    revalidate-url-key param dup [ >url dup check-url swap and ] when ;
+
+: handle-post ( action -- response )
+    '[
+        form-nesting-key params get at " " split
+        [ , (handle-post) ]
+        [ swap '[ , , nest-values ] ] reduce
+        call
+    ] with-exit-continuation
+    [
+        revalidate-url
+        [ flashed-variables <flash-redirect> ] [ <403> ] if*
+    ] unless* ;
+
+: handle-rest-param ( path action -- assoc )
+    rest-param>> dup [ associate ] [ 2drop f ] if ;
+
+: init-action ( path action -- )
+    blank-values
+    init-validation
+    handle-rest-param
+    request get request-params assoc-union params set ;
+
+M: action call-responder* ( path action -- response )
+    [ init-action ] keep
+    request get method>> {
+        { "GET" [ handle-get ] }
+        { "HEAD" [ handle-get ] }
+        { "POST" [ handle-post ] }
+    } case ;
+
+M: action modify-form
+    drop request get url>> revalidate-url-key hidden-form-field ;
+
 : check-validation ( -- )
     validation-failed? [ validation-failed ] when ;
 

extra/furnace/asides/asides.factor

@@ -0,0 +1,73 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces sequences arrays kernel
+assocs assocs.lib hashtables math.parser urls combinators
+furnace http http.server http.server.filters furnace.sessions
+html.elements html.templates.chloe.syntax ;
+IN: furnace.asides
+
+TUPLE: asides < filter-responder ;
+
+C: <asides> asides
+
+: begin-aside* ( -- id )
+    request get
+    [ url>> ] [ post-data>> ] [ method>> ] tri 3array
+    asides sget set-at-unique
+    session-changed ;
+
+: end-aside-post ( url post-data -- response )
+    request [
+        clone
+            swap >>post-data
+            swap >>url
+    ] change
+    request get url>> path>> split-path
+    asides get responder>> call-responder ;
+
+ERROR: end-aside-in-get-error ;
+
+: end-aside* ( url id -- response )
+    request get method>> "POST" = [ end-aside-in-get-error ] unless
+    asides sget at [
+        first3 {
+            { "GET" [ drop <redirect> ] }
+            { "HEAD" [ drop <redirect> ] }
+            { "POST" [ end-aside-post ] }
+        } case
+    ] [ <redirect> ] ?if ;
+
+SYMBOL: aside-id
+
+: aside-id-key "__a" ;
+
+: begin-aside ( -- )
+    begin-aside* aside-id set ;
+
+: end-aside ( default -- response )
+    aside-id [ f ] change end-aside* ;
+
+M: asides call-responder*
+    dup asides set
+    aside-id-key request get request-params at aside-id set
+    call-next-method ;
+
+M: asides init-session*
+    H{ } clone asides sset
+    call-next-method ;
+
+M: asides link-attr ( tag -- )
+    drop
+    "aside" optional-attr {
+        { "none" [ aside-id off ] }
+        { "begin" [ begin-aside ] }
+        { "current" [ ] }
+        { f [ ] }
+    } case ;
+
+M: asides modify-query ( query responder -- query' )
+    drop
+    aside-id get [ aside-id-key associate assoc-union ] when* ;
+
+M: asides modify-form ( responder -- )
+    drop aside-id get aside-id-key hidden-form-field ;

extra/furnace/auth/login/login.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors quotations assocs kernel splitting
 combinators sequences namespaces hashtables sets
-fry arrays threads qualified random validators
+fry arrays threads qualified random validators words
 io
 io.sockets
 io.encodings.utf8
@@ -26,14 +26,29 @@ furnace.auth
 furnace.auth.providers
 furnace.auth.providers.db
 furnace.actions
-furnace.flows
+furnace.asides
+furnace.flash
 furnace.sessions
 furnace.boilerplate ;
 QUALIFIED: smtp
 IN: furnace.auth.login
 
+: word>string ( word -- string )
+    [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
+
+: words>strings ( seq -- seq' )
+    [ word>string ] map ;
+
+: string>word ( string -- word )
+    ":" split1 swap lookup ;
+
+: strings>words ( seq -- seq' )
+    [ string>word ] map ;
+
 TUPLE: login < dispatcher users checksum ;
 
+TUPLE: protected < filter-responder description capabilities ;
+
 : users ( -- provider )
     login get users>> ;
 
@@ -64,7 +79,7 @@ M: user-saver dispose
 
 ! ! ! Login
 : successful-login ( user -- response )
-    username>> set-uid URL" $login" end-flow ;
+    username>> set-uid URL" $login" end-aside ;
 
 : login-failed ( -- * )
     "invalid username or password" validation-error
@@ -72,6 +87,13 @@ M: user-saver dispose
 
 : <login-action> ( -- action )
     <page-action>
+        [
+            protected fget [
+                [ description>> "description" set-value ]
+                [ capabilities>> words>strings "capabilities" set-value ] bi
+            ] when*
+        ] >>init
+
         { login "login" } >>template
 
         [
@@ -177,7 +199,7 @@ M: user-saver dispose
 
             drop
 
-            URL" $login" end-flow
+            URL" $login" end-aside
         ] >>submit ;
 
 ! ! ! Password recovery
@@ -290,23 +312,23 @@ SYMBOL: lost-password-from
     <action>
         [
             f set-uid
-            URL" $login" end-flow
+            URL" $login" end-aside
         ] >>submit ;
 
 ! ! ! Authentication logic
-
+: <protected> ( responder -- protected )
-TUPLE: protected < filter-responder capabilities ;
+    protected new
-
+        swap >>responder ;
-C: <protected> protected
 
 : show-login-page ( -- response )
-    begin-flow
+    begin-aside
-    URL" $login/login" <redirect> ;
+    URL" $login/login" { protected } <flash-redirect> ;
 
 : check-capabilities ( responder user -- ? )
     [ capabilities>> ] bi@ subset? ;
 
 M: protected call-responder* ( path responder -- response )
+    dup protected set
     uid dup [
         users get-user 2dup check-capabilities [
             [ logged-in-user set ] [ save-user-after ] bi
@@ -337,7 +359,9 @@ M: login call-responder* ( path responder -- response )
 ! ! ! Configuration
 
 : allow-edit-profile ( login -- login )
-    <edit-profile-action> f <protected> <login-boilerplate>
+    <edit-profile-action> <protected>
+        "edit your profile" >>description
+    <login-boilerplate>
         "edit-profile" add-responder ;
 
 : allow-registration ( login -- login )

extra/furnace/auth/login/login.xml

@@ -4,6 +4,19 @@
 
 	<t:title>Login</t:title>
 
+	<t:if t:value="description">
+		<p>You must log in to <t:label t:name="description" />.</p>
+	</t:if>
+
+	<t:if t:value="capabilities">
+		<p>Your user must have the following capabilities:</p>
+		<ul>
+			<t:each t:name="capabilities">
+				<li><t:label t:name="value" /></li>
+			</t:each>
+		</ul>
+	</t:if>
+
 	<t:form t:action="login">
 
 		<table>

extra/furnace/flash/flash.factor

@@ -0,0 +1,38 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs assocs.lib kernel sequences urls
+http http.server http.server.filters http.server.redirection
+furnace furnace.sessions ;
+IN: furnace.flash
+
+: flash-id-key "__f" ;
+
+TUPLE: flash-scopes < filter-responder ;
+
+C: <flash-scopes> flash-scopes
+
+SYMBOL: flash-scope
+
+: fget ( key -- value ) flash-scope get at ;
+
+M: flash-scopes call-responder*
+    flash-id-key
+    request get request-params at
+    flash-scopes sget at flash-scope set
+    call-next-method ;
+
+M: flash-scopes init-session*
+    H{ } clone flash-scopes sset
+    call-next-method ;
+
+: make-flash-scope ( seq -- id )
+    [ dup get ] H{ } map>assoc flash-scopes sget set-at-unique
+    session-changed ;
+
+: <flash-redirect> ( url seq -- response )
+    make-flash-scope
+    [ clone ] dip flash-id-key set-query-param
+    <redirect> ;
+
+: restore-flash ( seq -- )
+    [ flash-scope get key? ] filter [ [ fget ] keep set ] each ;

extra/furnace/flows/flows.factor

@@ -1,78 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces sequences arrays kernel
-assocs assocs.lib hashtables math.parser urls combinators
-furnace http http.server http.server.filters furnace.sessions
-html.elements html.templates.chloe.syntax ;
-IN: furnace.flows
-
-TUPLE: flows < filter-responder ;
-
-C: <flows> flows
-
-: begin-flow* ( -- id )
-    request get
-    [ url>> ] [ post-data>> ] [ method>> ] tri 3array
-    flows sget set-at-unique
-    session-changed ;
-
-: end-flow-post ( url post-data -- response )
-    request [
-        clone
-            "POST" >>method
-            swap >>post-data
-            swap >>url
-    ] change
-    request get url>> path>> split-path
-    flows get responder>> call-responder ;
-
-: end-flow* ( url id -- response )
-    flows sget at [
-        first3 {
-            { "GET" [ drop <redirect> ] }
-            { "HEAD" [ drop <redirect> ] }
-            { "POST" [ end-flow-post ] }
-        } case
-    ] [ <redirect> ] ?if ;
-
-SYMBOL: flow-id
-
-: flow-id-key "factorflowid" ;
-
-: begin-flow ( -- )
-    begin-flow* flow-id set ;
-
-: end-flow ( default -- response )
-    flow-id get end-flow* ;
-
-M: flows call-responder*
-    dup flows set
-    flow-id-key request get request-params at flow-id set
-    call-next-method ;
-
-M: flows init-session*
-    H{ } clone flows sset
-    call-next-method ;
-
-M: flows link-attr ( tag -- )
-    drop
-    "flow" optional-attr {
-        { "none" [ flow-id off ] }
-        { "begin" [ begin-flow ] }
-        { "current" [ ] }
-        { f [ ] }
-    } case ;
-
-M: flows modify-query ( query responder -- query' )
-    drop
-    flow-id get [ flow-id-key associate assoc-union ] when* ;
-
-M: flows hidden-form-field ( responder -- )
-    drop
-    flow-id get [
-        <input
-            "hidden" =type
-            flow-id-key =name
-            =value
-        input/>
-    ] when* ;

extra/furnace/furnace-tests.factor

@@ -1,6 +1,7 @@
 IN: furnace.tests
 USING: http.server.dispatchers http.server.responses
-http.server furnace tools.test kernel namespaces accessors ;
+http.server furnace tools.test kernel namespaces accessors
+io.streams.string ;
 TUPLE: funny-dispatcher < dispatcher ;
 
 : <funny-dispatcher> funny-dispatcher new-dispatcher ;
@@ -28,3 +29,7 @@ M: base-path-check-responder call-responder*
     V{ } responder-nesting set
     "a/b/c" split-path main-responder get call-responder body>>
 ] unit-test
+
+[ "<input type='hidden' name='foo' value='&amp;&amp;&amp;' />" ]
+[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
+unit-test

extra/furnace/furnace.factor

@@ -6,6 +6,7 @@ vocabs.loader classes
 fry urls multiline
 xml
 xml.data
+xml.entities
 xml.writer
 xml.utilities
 html.components
@@ -64,15 +65,19 @@ M: object modify-query drop ;
         { "POST" [ <permanent-redirect> ] }
     } case ;
 
-GENERIC: hidden-form-field ( responder -- )
+GENERIC: modify-form ( responder -- )
 
-M: object hidden-form-field drop ;
+M: object modify-form drop ;
 
 : request-params ( request -- assoc )
     dup method>> {
         { "GET" [ url>> query>> ] }
         { "HEAD" [ url>> query>> ] }
-        { "POST" [ post-data>> ] }
+        { "POST" [
+            post-data>>
+            dup content-type>> "application/x-www-form-urlencoded" =
+            [ content>> ] [ drop f ] if
+        ] }
     } case ;
 
 SYMBOL: exit-continuation
@@ -128,20 +133,34 @@ CHLOE: a
     [ drop </a> ]
     tri ;
 
+: hidden-form-field ( value name -- )
+    over [
+        <input
+            "hidden" =type
+            =name
+            object>string =value
+        input/>
+    ] [ 2drop ] if ;
+
+: form-nesting-key "factorformnesting" ;
+
+: form-magic ( tag -- )
+    [ modify-form ] each-responder
+    nested-values get " " join f like form-nesting-key hidden-form-field
+    "for" optional-attr [ hidden render ] when* ;
+
 : form-start-tag ( tag -- )
     [
         [
             <form
-            "POST" =method
+                "POST" =method
-            [ link-attrs ]
+                [ link-attrs ]
-            [ "action" required-attr resolve-base-path =action ]
+                [ "action" required-attr resolve-base-path =action ]
-            [ tag-attrs non-chloe-attrs-only print-attrs ]
+                [ tag-attrs non-chloe-attrs-only print-attrs ]
-            tri
+                tri
             form>
-        ] [
+        ]
-            [ hidden-form-field ] each-responder
+        [ form-magic ] bi
-            "for" optional-attr [ hidden render ] when*
-        ] bi
     ] with-scope ;
 
 CHLOE: form
@@ -167,17 +186,3 @@ CHLOE: button
         [ [ children>string 1array ] dip "button" tag-named set-tag-children ]
         [ nip ]
     } 2cleave process-chloe-tag ;
-
-: attr>word ( value -- word/f )
-    dup ":" split1 swap lookup
-    [ ] [ "No such word: " swap append throw ] ?if ;
-
-: attr>var ( value -- word/f )
-    attr>word dup symbol? [
-        "Must be a symbol: " swap append throw
-    ] unless ;
-
-: if-satisfied? ( tag -- ? )
-    "code" required-attr attr>word execute ;
-
-CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;

extra/furnace/sessions/sessions.factor

@@ -109,14 +109,14 @@ M: session-saver dispose
     [ session set ] [ save-session-after ] bi
     sessions get responder>> call-responder ;
 
-: session-id-key "factorsessid" ;
+: session-id-key "__s" ;
 
 : cookie-session-id ( request -- id/f )
     session-id-key get-cookie
     dup [ value>> string>number ] when ;
 
 : post-session-id ( request -- id/f )
-    session-id-key swap post-data>> at string>number ;
+    session-id-key swap request-params at string>number ;
 
 : request-session-id ( -- id/f )
     request get dup method>> {
@@ -137,13 +137,8 @@ M: session-saver dispose
 : put-session-cookie ( response -- response' )
     session get id>> number>string <session-cookie> put-cookie ;
 
-M: sessions hidden-form-field ( responder -- )
+M: sessions modify-form ( responder -- )
-    drop
+    drop session get id>> session-id-key hidden-form-field ;
-    <input
-        "hidden" =type
-        session-id-key =name
-        session get id>> number>string =value
-    input/> ;
 
 M: sessions call-responder* ( path responder -- response )
     sessions set

extra/html/components/components.factor

@@ -29,22 +29,30 @@ SYMBOL: values
 : deposit-slots ( destination names -- )
     [ <mirror> ] dip deposit-values ;
 
-: with-each-index ( seq quot -- )
+: with-each-index ( name quot -- )
-    '[
+    [ value ] dip '[
         [
-            values [ clone ] change
+            blank-values
             1+ "index" set-value @
         ] with-scope
     ] each-index ; inline
 
-: with-each-value ( seq quot -- )
+: with-each-value ( name quot -- )
     '[ "value" set-value @ ] with-each-index ; inline
 
-: with-each-object ( seq quot -- )
+: with-each-object ( name quot -- )
     '[ from-object @ ] with-each-index ; inline
 
-: with-values ( object quot -- )
+SYMBOL: nested-values
-    '[ blank-values , from-object @ ] with-scope ; inline
+
+: with-values ( name quot -- )
+    '[
+        ,
+        [ nested-values [ swap prefix ] change ]
+        [ value blank-values from-object ]
+        bi
+        @
+    ] with-scope ; inline
 
 : nest-values ( name quot -- )
     swap [

extra/html/templates/chloe/chloe-tests.factor

@@ -148,3 +148,23 @@ TUPLE: person first-name last-name ;
         "test9" test-template call-template
     ] run-template
 ] unit-test
+
+[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
+
+[ "<form method='POST' action='foo'><input type='hidden' name='factorformnesting' value='a'/></form>" ] [
+    [
+        "test10" test-template call-template
+    ] run-template
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [
+    H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value
+] unit-test
+
+[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr></table>" ] [
+    [
+        "test11" test-template call-template
+    ] run-template [ blank? not ] filter
+] unit-test

extra/html/templates/chloe/chloe.factor

@@ -68,7 +68,7 @@ CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
 
 : (bind-tag) ( tag quot -- )
     [
-        [ "name" required-attr value ] keep
+        [ "name" required-attr ] keep
         '[ , process-tag-children ]
     ] dip call ; inline
 
@@ -85,6 +85,17 @@ CHLOE: comment drop ;
 
 CHLOE: call-next-template drop call-next-template ;
 
+: attr>word ( value -- word/f )
+    dup ":" split1 swap lookup
+    [ ] [ "No such word: " swap append throw ] ?if ;
+
+: if-satisfied? ( tag -- ? )
+    [ "code" optional-attr [ attr>word execute ] [ t ] if* ]
+    [ "value" optional-attr [ value ] [ t ] if* ]
+    bi and ;
+
+CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
+
 CHLOE-SINGLETON: label
 CHLOE-SINGLETON: link
 CHLOE-SINGLETON: farkup

extra/html/templates/chloe/test/test10.xml

@@ -0,0 +1,3 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:bind t:name="a"><t:form t:action="foo"/></t:bind></t:chloe>

extra/html/templates/chloe/test/test11.xml

@@ -0,0 +1,14 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<table>
+		<t:bind t:name="person">
+			<tr>
+				<td><t:label t:name="first-name"/></td>
+				<td><t:label t:name="last-name"/></td>
+			</tr>
+		</t:bind>
+	</table>
+
+</t:chloe>

extra/http/http-tests.factor

@@ -1,15 +1,16 @@
 USING: http tools.test multiline tuple-syntax
 io.streams.string kernel arrays splitting sequences
-assocs io.sockets db db.sqlite continuations urls ;
+assocs io.sockets db db.sqlite continuations urls hashtables ;
 IN: http.tests
 
 : lf>crlf "\n" split "\r\n" join ;
 
 STRING: read-request-test-1
-GET http://foo/bar HTTP/1.1
+POST http://foo/bar HTTP/1.1
 Some-Header: 1
 Some-Header: 2
 Content-Length: 4
+Content-type: application/octet-stream
 
 blah
 ;
@@ -17,10 +18,10 @@ blah
 [
     TUPLE{ request
         url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
-        method: "GET"
+        method: "POST"
         version: "1.1"
-        header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
+        header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
-        post-data: "blah"
+        post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" }
         cookies: V{ }
     }
 ] [
@@ -30,8 +31,9 @@ blah
 ] unit-test
 
 STRING: read-request-test-1'
-GET /bar HTTP/1.1
+POST /bar HTTP/1.1
 content-length: 4
+content-type: application/octet-stream
 some-header: 1; 2
 
 blah
@@ -87,7 +89,7 @@ blah
         code: 404
         message: "not found"
         header: H{ { "content-type" "text/html; charset=UTF8" } }
-        cookies: V{ }
+        cookies: { }
         content-type: "text/html"
         content-charset: "UTF8"
     }
@@ -172,7 +174,7 @@ test-db [
 [ ] [
     [
         <dispatcher>
-            <action> f <protected>
+            <action> <protected>
             <login>
             <sessions>
             "" add-responder
@@ -219,3 +221,56 @@ test-db [
 [ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test
 
 [ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
+
+USING: html.components html.elements xml xml.utilities validators
+furnace furnace.flash ;
+
+SYMBOL: a
+
+[ ] [
+    [
+        <dispatcher>
+            <action>
+                [ a get-global "a" set-value ] >>init
+                [ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
+                [ { { "a" [ v-integer ] } } validate-params ] >>validate
+                [ "a" value a set-global URL" " <redirect> ] >>submit
+            <flash-scopes>
+            <sessions>
+            >>default
+            add-quit-action
+        test-db <db-persistence>
+        main-responder set
+
+        [ 1237 httpd ] "HTTPD test" spawn drop
+    ] with-scope
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+3 a set-global
+
+: test-a string>xml "input" tag-named "value" swap at ;
+
+[ "3" ] [
+    "http://localhost:1237/" http-get*
+    swap dup cookies>> "cookies" set session-id-key get-cookie
+    value>> "session-id" set test-a
+] unit-test
+
+[ "4" ] [
+    H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
+    "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+] unit-test
+
+[ 4 ] [ a get-global ] unit-test
+
+! Test flash scope
+[ "xyz" ] [
+    H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
+    "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+] unit-test
+
+[ 4 ] [ a get-global ] unit-test
+
+[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test

extra/http/http.factor

@@ -10,7 +10,7 @@ io io.server io.sockets.secure
 
 unicode.case unicode.categories qualified
 
-urls html.templates ;
+urls html.templates xml xml.data xml.writer ;
 
 EXCLUDE: fry => , ;
 
@@ -132,7 +132,6 @@ url
 version
 header
 post-data
-post-data-type
 cookies ;
 
 : set-header ( request/response value key -- request/response )
@@ -177,19 +176,27 @@ cookies ;
 : header ( request/response key -- value )
     swap header>> at ;
 
-SYMBOL: max-post-request
+TUPLE: post-data raw content content-type ;
 
-1024 256 * max-post-request set-global
+: <post-data> ( raw content-type -- post-data )
+    post-data new
+        swap >>content-type
+        swap >>raw ;
 
-: content-length ( header -- n )
+: parse-post-data ( post-data -- post-data )
-    "content-length" swap at string>number dup [
+    [ ] [ raw>> ] [ content-type>> ] tri {
-        dup max-post-request get > [
+        { "application/x-www-form-urlencoded" [ query>assoc ] }
-            "content-length > max-post-request" throw
+        { "text/xml" [ string>xml ] }
-        ] when
+        [ drop ]
-    ] when ;
+    } case >>content ;
 
 : read-post-data ( request -- request )
-    dup header>> content-length [ read >>post-data ] when* ;
+    dup method>> "POST" = [
+        [ ]
+        [ "content-length" header string>number read ]
+        [ "content-type" header ] tri
+        <post-data> parse-post-data >>post-data
+    ] when ;
 
 : extract-host ( request -- request )
     [ ] [ url>> ] [ "host" header parse-host ] tri
@@ -197,13 +204,6 @@ SYMBOL: max-post-request
     ensure-port
     drop ;
 
-: extract-post-data-type ( request -- request )
-    dup "content-type" header >>post-data-type ;
-
-: parse-post-data ( request -- request )
-    dup post-data-type>> "application/x-www-form-urlencoded" =
-    [ dup post-data>> query>assoc >>post-data ] when ;
-
 : extract-cookies ( request -- request )
     dup "cookie" header [ parse-cookies >>cookies ] when* ;
 
@@ -225,8 +225,6 @@ SYMBOL: max-post-request
     read-post-data
     detect-protocol
     extract-host
-    extract-post-data-type
-    parse-post-data
     extract-cookies ;
 
 : write-method ( request -- request )
@@ -238,12 +236,6 @@ SYMBOL: max-post-request
 : write-version ( request -- request )
     "HTTP/" write dup request-version write crlf ;
 
-: unparse-post-data ( request -- request )
-    dup post-data>> dup sequence? [ drop ] [
-        assoc>query >>post-data
-        "application/x-www-form-urlencoded" >>post-data-type
-    ] if ;
-
 : url-host ( url -- string )
     [ host>> ] [ port>> ] bi dup "http" protocol-port =
     [ drop ] [ ":" swap number>string 3append ] if ;
@@ -251,13 +243,33 @@ SYMBOL: max-post-request
 : write-request-header ( request -- request )
     dup header>> >hashtable
     over url>> host>> [ over url>> url-host "host" pick set-at ] when
-    over post-data>> [ length "content-length" pick set-at ] when*
+    over post-data>> [
-    over post-data-type>> [ "content-type" pick set-at ] when*
+        [ raw>> length "content-length" pick set-at ]
+        [ content-type>> "content-type" pick set-at ]
+        bi
+    ] when*
     over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
     write-header ;
 
+GENERIC: >post-data ( object -- post-data )
+
+M: post-data >post-data ;
+
+M: string >post-data "application/octet-stream" <post-data> ;
+
+M: byte-array >post-data "application/octet-stream" <post-data> ;
+
+M: xml >post-data xml>string "text/xml" <post-data> ;
+
+M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
+
+M: f >post-data ;
+
+: unparse-post-data ( request -- request )
+    [ >post-data ] change-post-data ;
+
 : write-post-data ( request -- request )
-    dup post-data>> [ write ] when* ;
+    dup method>> "POST" = [ dup post-data>> raw>> write ] when ; 
 
 : write-request ( request -- )
     unparse-post-data
@@ -307,7 +319,7 @@ body ;
 
 : read-response-header
     read-header >>header
-    extract-cookies
+    dup "set-cookie" header parse-cookies >>cookies
     dup "content-type" header [
         parse-content-type [ >>content-type ] [ >>content-charset ] bi*
     ] when* ;

extra/http/server/cgi/cgi.factor

@@ -35,8 +35,10 @@ IN: http.server.cgi
         request get "accept" header "HTTP_ACCEPT" set
 
         post? [
-            request get post-data-type>> "CONTENT_TYPE" set
+            request get post-data>> raw>>
-            request get post-data>> length number>string "CONTENT_LENGTH" set
+            [ "CONTENT_TYPE" set ]
+            [ length number>string "CONTENT_LENGTH" set ]
+            bi
         ] when
     ] H{ } make-assoc ;
 
@@ -51,7 +53,7 @@ IN: http.server.cgi
     "CGI output follows" >>message
     swap '[
         , output-stream get swap <cgi-process> <process-stream> [
-            post? [ request get post-data>> write flush ] when
+            post? [ request get post-data>> raw>> write flush ] when
             input-stream get swap (stream-copy)
         ] with-stream
     ] >>body ;

extra/http/server/server-tests.factor

@@ -0,0 +1,4 @@
+USING: http http.server math sequences continuations tools.test ;
+IN: http.server.tests
+
+[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test

extra/http/server/server.factor

@@ -40,7 +40,7 @@ main-responder global [ <404> <trivial-responder> or ] change-at
 
 : <500> ( error -- response )
     500 "Internal server error" <trivial-response>
-    development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ;
+    swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
 
 : do-response ( response -- )
     dup write-response

extra/webapps/factor-website/factor-website.factor

@@ -6,7 +6,8 @@ namespaces db db.sqlite smtp
 http.server
 http.server.dispatchers
 furnace.db
-furnace.flows
+furnace.asides
+furnace.flash
 furnace.sessions
 furnace.auth.login
 furnace.auth.providers.db
@@ -53,8 +54,7 @@ TUPLE: factor-website < dispatcher ;
         allow-edit-profile
     <boilerplate>
         { factor-website "page" } >>template
-    <flows>
+    <asides> <flash-scopes> <sessions>
-    <sessions>
     test-db <db-persistence> ;
 
 : init-factor-website ( -- )

extra/webapps/pastebin/paste.xml

@@ -28,7 +28,7 @@
 
 		<pre class="description"><t:code t:name="contents" t:mode="mode"/></pre>
 
-		<t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
+		<t:button t:action="$pastebin/delete-annotation" t:for="id" class="link-button link">Delete Annotation</t:button>
 
 	</t:bind-each>
 
@@ -36,13 +36,13 @@
 
 		<h2>New Annotation</h2>
 
-		<t:form t:action="$pastebin/new-annotation" t:for="id">
+		<t:form t:action="$pastebin/new-annotation" t:for="parent">
 
 			<table>
 				<tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
 				<tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
 				<tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
-				<tr><th class="field-label big-field-label">Body:</th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
+				<tr><th class="field-label big-field-label">Body: </th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
 				<tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
 				<tr>
 				<td></td>

extra/webapps/pastebin/pastebin-common.xml

@@ -14,10 +14,10 @@
 		<t:if t:code="furnace.sessions:uid">
 
 			<t:if t:code="furnace.auth.login:allow-edit-profile?">
-				| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+				| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
 			</t:if>
 
-			| <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+			| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
 
 		</t:if>
 

extra/webapps/pastebin/pastebin.factor

@@ -132,7 +132,7 @@ M: annotation entity-link
 
             "id" value
             "new-annotation" [
-                "id" set-value
+                "parent" set-value
                 mode-names "modes" set-value
                 "factor" "mode" set-value
             ] nest-values
@@ -212,12 +212,12 @@ M: annotation entity-link
         ] >>display
 
         [
-            { { "id" [ v-integer ] } } validate-params
+            { { "parent" [ v-integer ] } } validate-params
             validate-entity
         ] >>validate
 
         [
-            "id" value f <annotation>
+            "parent" value f <annotation>
             [ deposit-entity-slots ]
             [ insert-tuple ]
             [ entity-link <redirect> ]
@@ -246,9 +246,13 @@ can-delete-pastes? define-capability
         <paste-action> "paste" add-responder
         <paste-feed-action> "paste.atom" add-responder
         <new-paste-action> "new-paste" add-responder
-        <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
+        <delete-paste-action> <protected>
+            "delete pastes" >>description
+            { can-delete-pastes? } >>capabilities "delete-paste" add-responder
         <new-annotation-action> "new-annotation" add-responder
-        <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
+        <delete-annotation-action> <protected>
+            "delete annotations" >>description
+            { can-delete-pastes? } >>capabilities "delete-annotation" add-responder
     <boilerplate>
         { pastebin "pastebin-common" } >>template ;
 

extra/webapps/planet/planet-common.xml

@@ -11,10 +11,10 @@
 
 		<t:if t:code="furnace.sessions:uid">
 			<t:if t:code="furnace.auth.login:allow-edit-profile?">
-				| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+				| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
 			</t:if>
 	
-			| <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+			| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
 		</t:if>
 	</div>
 

extra/webapps/planet/planet.factor

@@ -198,7 +198,10 @@ can-administer-planet-factor? define-capability
     planet-factor new-dispatcher
         <planet-action> "list" add-main-responder
         <feed-action> "feed.xml" add-responder
-        <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
+        <planet-factor-admin> <protected>
+            "administer Planet Factor" >>description
+            { can-administer-planet-factor? } >>capabilities
+        "admin" add-responder
     <boilerplate>
         { planet-factor "planet-common" } >>template ;
 

extra/webapps/todo/todo.factor

@@ -122,4 +122,5 @@ todo "TODO"
         <delete-action> "delete" add-responder
     <boilerplate>
         { todo-list "todo" } >>template
-    f <protected> ;
+    <protected>
+        "view your todo list" >>description ;

extra/webapps/todo/todo.xml

@@ -9,10 +9,10 @@
 		| <t:a t:href="$todo-list/new">Add Item</t:a>
 
 		<t:if t:code="furnace.auth.login:allow-edit-profile?">
-			| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+			| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
 		</t:if>
 
-		| <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+		| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
 	</div>
 
 	<h1><t:write-title /></h1>

extra/webapps/user-admin/user-admin.factor

@@ -18,18 +18,6 @@ IN: webapps.user-admin
 
 TUPLE: user-admin < dispatcher ;
 
-: word>string ( word -- string )
-    [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
-
-: words>strings ( seq -- seq' )
-    [ word>string ] map ;
-
-: string>word ( string -- word )
-    ":" split1 swap lookup ;
-
-: strings>words ( seq -- seq' )
-    [ string>word ] map ;
-
 : <user-list-action> ( -- action )
     <page-action>
         [ f <user> select-tuples "users" set-value ] >>init
@@ -156,7 +144,9 @@ can-administer-users? define-capability
         <delete-user-action> "delete" add-responder
     <boilerplate>
         { user-admin "user-admin" } >>template
-    { can-administer-users? } <protected> ;
+    <protected>
+        "administer users" >>description
+        { can-administer-users? } >>capabilities ;
 
 : make-admin ( username -- )
     <user>

extra/webapps/user-admin/user-admin.xml

@@ -7,10 +7,10 @@
 		| <t:a t:href="$user-admin/new">Add User</t:a>
 
 		<t:if t:code="furnace.auth.login:allow-edit-profile?">
-			| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+			| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
 		</t:if>
 
-		| <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+		| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
 	</div>
 
 	<h1><t:write-title /></h1>

extra/webapps/wiki/changes.xml

@@ -7,7 +7,7 @@
 	<ul>
 		<t:bind-each t:name="changes">
 			<li>
-				<t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a>
+				<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
 				on
 				<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
 				by

extra/webapps/wiki/wiki-common.xml

@@ -13,10 +13,10 @@
 		<t:if t:code="furnace.sessions:uid">
 
 			<t:if t:code="furnace.auth.login:allow-edit-profile?">
-				| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+				| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
 			</t:if>
 
-			| <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+			| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
 
 		</t:if>
 

extra/webapps/wiki/wiki.factor

@@ -214,6 +214,10 @@ revision "REVISIONS" {
 
         { wiki "user-edits" } >>template ;
 
+SYMBOL: can-delete-wiki-articles?
+
+can-delete-wiki-articles? define-capability
+
 : <wiki> ( -- dispatcher )
     wiki new-dispatcher
         <dispatcher>
@@ -222,7 +226,9 @@ revision "REVISIONS" {
             <view-revision-action> "revision" add-responder
             <list-revisions-action> "revisions" add-responder
             <diff-action> "diff" add-responder
-            <edit-article-action> { } <protected> "edit" add-responder
+            <edit-article-action> <protected>
+                "edit wiki articles" >>description
+                "edit" add-responder
         <boilerplate>
             { wiki "page-common" } >>template
         >>default
@@ -230,6 +236,9 @@ revision "REVISIONS" {
         <user-edits-action> "user-edits" add-responder
         <list-articles-action> "articles" add-responder
         <list-changes-action> "changes" add-responder
-        <delete-action> { } <protected> "delete" add-responder
+        <delete-action> <protected>
+            "delete wiki articles" >>description
+            { can-delete-wiki-articles? } >>capabilities
+        "delete" add-responder
     <boilerplate>
         { wiki "wiki-common" } >>template ;

extra/xml-rpc/example.factor

@@ -22,6 +22,6 @@ USING: kernel hashtables xml-rpc xml calendar sequences
     put-http-response ;
 
 : test-rpc-arith
-    "add" { 1 2 } <rpc-method> send-rpc xml>string
+    "add" { 1 2 } <rpc-method> send-rpc
-    "text/xml" swap "http://localhost:8080/responder/rpc/"
+    "http://localhost:8080/responder/rpc/"
     http-post ;

extra/xml-rpc/xml-rpc.factor

@@ -158,8 +158,7 @@ TAG: array xml>item
 
 : post-rpc ( rpc url -- rpc )
     ! This needs to do something in the event of an error
-    >r "text/xml" swap send-rpc xml>string r> http-post
+    >r send-rpc r> http-post nip string>xml receive-rpc ;
-    2nip string>xml receive-rpc ;
 
 : invoke-method ( params method url -- )
     >r swap <rpc-method> r> post-rpc ;