Big web framework refactoring

extra/furnace/actions/actions.factor

@@ -1,9 +1,16 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences kernel assocs combinators http.server
+USING: accessors sequences kernel assocs combinators
 validators http hashtables namespaces fry continuations locals
-boxes xml.entities html.elements html.components
+io arrays math boxes
-html.templates.chloe io arrays math ;
+xml.entities
+http.server
+http.server.responses
+furnace
+html.elements
+html.components
+html.templates.chloe
+html.templates.chloe.syntax ;
 IN: furnace.actions
 
 SYMBOL: params
@@ -92,9 +99,3 @@ TUPLE: page-action < action template ;
 : <page-action> ( -- page )
     page-action new-action
         dup '[ , template>> <chloe-content> ] >>display ;
-
-TUPLE: feed-action < action feed ;
-
-: <feed-action> ( -- feed )
-    feed-action new-action
-        dup '[ , feed>> call <feed-content> ] >>display ;

extra/furnace/auth/auth.factor

@@ -2,6 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs namespaces kernel sequences sets
 http.server
+http.server.filters
+http.server.dispatchers
 furnace.sessions
 furnace.auth.providers ;
 IN: furnace.auth

extra/furnace/auth/login/login.factor

@@ -18,6 +18,10 @@ html.elements
 urls
 http
 http.server
+http.server.dispatchers
+http.server.filters
+http.server.responses
+furnace
 furnace.auth
 furnace.auth.providers
 furnace.auth.providers.db
@@ -60,7 +64,7 @@ M: user-saver dispose
 
 ! ! ! Login
 : successful-login ( user -- response )
-    username>> set-uid "$login" end-flow ;
+    username>> set-uid URL" $login" end-flow ;
 
 : login-failed ( -- * )
     "invalid username or password" validation-error
@@ -68,7 +72,7 @@ M: user-saver dispose
 
 : <login-action> ( -- action )
     <page-action>
-        "$login/login" >>template
+        { login "login" } >>template
 
         [
             {
@@ -97,7 +101,7 @@ M: user-saver dispose
 
 : <register-action> ( -- action )
     <page-action>
-        "$login/register" >>template
+        { login "register" } >>template
 
         [
             {
@@ -138,7 +142,7 @@ M: user-saver dispose
             tri
         ] >>init
 
-        "$login/edit-profile" >>template
+        { login "edit-profile" } >>template
 
         [
             uid "username" set-value
@@ -173,7 +177,7 @@ M: user-saver dispose
 
             drop
 
-            "$login" end-flow
+            URL" $login" end-flow
         ] >>submit ;
 
 ! ! ! Password recovery
@@ -219,7 +223,7 @@ SYMBOL: lost-password-from
 
 : <recover-action-1> ( -- action )
     <page-action>
-        "$login/recover-1" >>template
+        { login "recover-1" } >>template
 
         [
             {
@@ -240,7 +244,7 @@ SYMBOL: lost-password-from
 
 : <recover-action-2> ( -- action )
     <page-action>
-        "$login/recover-2" >>template ;
+        { login "recover-2" } >>template ;
 
 : <recover-action-3> ( -- action )
     <page-action>
@@ -251,7 +255,7 @@ SYMBOL: lost-password-from
             } validate-params
         ] >>init
 
-        "$login/recover-3" >>template
+        { login "recover-3" } >>template
 
         [
             {
@@ -273,20 +277,20 @@ SYMBOL: lost-password-from
 
                 URL" $login/recover-4" <redirect>
             ] [
-                <400>
+                <403>
             ] if*
         ] >>submit ;
 
 : <recover-action-4> ( -- action )
     <page-action>
-        "$login/recover-4" >>template ;
+        { login "recover-4" } >>template ;
 
 ! ! ! Logout
 : <logout-action> ( -- action )
     <action>
         [
             f set-uid
-            "$login/login" end-flow
+            URL" $login" end-flow
         ] >>submit ;
 
 ! ! ! Authentication logic
@@ -320,7 +324,7 @@ M: login call-responder* ( path responder -- response )
 
 : <login-boilerplate> ( responder -- responder' )
     <boilerplate>
-        "$login/boilerplate" >>template ;
+        { login "boilerplate" } >>template ;
 
 : <login> ( responder -- auth )
     login new-dispatcher

extra/furnace/auth/login/login.xml

@@ -30,11 +30,11 @@
 	</t:form>
 
 	<p>
-		<t:if code="http.server.auth.login:login-failed?">
+		<t:if t:code="furnace.auth.login:allow-registration?">
 			<t:a t:href="register">Register</t:a>
 		</t:if>
 		|
-		<t:if code="http.server.auth.login:allow-password-recovery?">
+		<t:if t:code="furnace.auth.login:allow-password-recovery?">
 			<t:a t:href="recover-password">Recover Password</t:a>
 		</t:if>
 	</p>

extra/furnace/boilerplate/boilerplate.factor

@@ -1,7 +1,11 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces http.server html.templates
+USING: accessors kernel namespaces
-html.templates.chloe locals ;
+html.templates html.templates.chloe
+locals
+http.server
+http.server.filters
+furnace ;
 IN: furnace.boilerplate
 
 TUPLE: boilerplate < filter-responder template ;

extra/furnace/db/db.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: db db.pools io.pools http.server furnace.sessions
+USING: kernel accessors continuations namespaces destructors
-kernel accessors continuations namespaces destructors ;
+db db.pools io.pools http.server http.server.filters
+furnace.sessions ;
 IN: furnace.db
 
 TUPLE: db-persistence < filter-responder pool ;

extra/furnace/flows/flows.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors namespaces sequences arrays kernel
 assocs assocs.lib hashtables math.parser urls combinators
-html.elements http http.server furnace.sessions
+furnace http http.server http.server.filters furnace.sessions
-html.templates.chloe.syntax ;
+html.elements html.templates.chloe.syntax ;
 IN: furnace.flows
 
 TUPLE: flows < filter-responder ;

extra/furnace/furnace-tests.factor

@@ -0,0 +1,30 @@
+IN: furnace.tests
+USING: http.server.dispatchers http.server.responses
+http.server furnace tools.test kernel namespaces accessors ;
+TUPLE: funny-dispatcher < dispatcher ;
+
+: <funny-dispatcher> funny-dispatcher new-dispatcher ;
+
+TUPLE: base-path-check-responder ;
+
+C: <base-path-check-responder> base-path-check-responder
+
+M: base-path-check-responder call-responder*
+    2drop
+    "$funny-dispatcher" resolve-base-path
+    "text/plain" <content> ;
+
+[ ] [
+    <dispatcher>
+        <dispatcher>
+            <funny-dispatcher>
+                <base-path-check-responder> "c" add-responder
+            "b" add-responder
+        "a" add-responder
+    main-responder set
+] unit-test
+
+[ "/a/b/" ] [
+    V{ } responder-nesting set
+    "a/b/c" split-path main-responder get call-responder body>>
+] unit-test

extra/furnace/furnace.factor

@@ -1,7 +1,69 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel combinators assocs
+continuations namespaces sequences splitting words
+vocabs.loader classes
+fry urls multiline
+xml
+xml.data
+xml.writer
+xml.utilities
+html.components
+html.elements
+html.templates
+html.templates.chloe
+html.templates.chloe.syntax
+http
+http.server
+http.server.redirection
+http.server.responses
+qualified ;
+QUALIFIED-WITH: assocs a
 IN: furnace
 
+: nested-responders ( -- seq )
+    responder-nesting get a:values ;
+
+: each-responder ( quot -- )
+   nested-responders swap each ; inline
+
+: base-path ( string -- pair )
+    dup responder-nesting get
+    [ second class word-name = ] with find nip
+    [ first ] [ "No such responder: " swap append throw ] ?if ;
+
+: resolve-base-path ( string -- string' )
+    "$" ?head [
+        [
+            "/" split1 [ base-path [  "/" % % ] each "/" % ] dip %
+        ] "" make
+    ] when ;
+
+: vocab-path ( vocab -- path )
+    dup vocab-dir vocab-append-path ;
+
+: resolve-template-path ( pair -- path )
+    [
+        first2 [ word-vocabulary vocab-path % ] [ "/" % % ] bi*
+    ] "" make ;
+
+GENERIC: modify-query ( query responder -- query' )
+
+M: object modify-query drop ;
+
+: adjust-url ( url -- url' )
+    clone
+        [ [ modify-query ] each-responder ] change-query
+        [ resolve-base-path ] change-path
+    relative-to-request ;
+
+: <redirect> ( url -- response )
+    adjust-url request get method>> {
+        { "GET" [ <temporary-redirect> ] }
+        { "HEAD" [ <temporary-redirect> ] }
+        { "POST" [ <permanent-redirect> ] }
+    } case ;
+
 GENERIC: hidden-form-field ( responder -- )
 
 M: object hidden-form-field drop ;
@@ -13,12 +75,6 @@ M: object hidden-form-field drop ;
         { "POST" [ post-data>> ] }
     } case ;
 
-: <feed-content> ( body -- response )
-    feed>xml "application/atom+xml" <content> ;
-
-: <json-content> ( obj -- response )
-    >json "application/json" <content> ;
-
 SYMBOL: exit-continuation
 
 : exit-with exit-continuation get continue-with ;
@@ -38,7 +94,7 @@ CHLOE: atom
     <url>
         swap >>query
         swap >>path
-    adjust-url
+    adjust-url relative-to-request
     add-atom-feed ;
 
 CHLOE: write-atom drop write-atom-feeds ;
@@ -62,7 +118,7 @@ M: object link-attr 2drop ;
             <url>
                 swap >>query
                 swap >>path
-            adjust-url =href
+            adjust-url relative-to-request =href
         a>
     ] with-scope ;
 
@@ -94,8 +150,6 @@ CHLOE: form
     [ drop </form> ]
     tri ;
 
-DEFER: process-chloe-tag
-
 STRING: button-tag-markup
 <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
     <button type="submit"></button>
@@ -124,13 +178,6 @@ CHLOE: button
     ] unless ;
 
 : if-satisfied? ( tag -- ? )
-    t swap
+    "code" required-attr attr>word execute ;
-    {
-        [ "code"  optional-attr [ attr>word execute and ] when* ]
-        [  "var"  optional-attr [ attr>var      get and ] when* ]
-        [ "svar"  optional-attr [ attr>var     sget and ] when* ]
-        [ "uvar"  optional-attr [ attr>var     uget and ] when* ]
-        [ "value" optional-attr [ value             and ] when* ]
-    } cleave ;
 
 CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;

extra/furnace/json/json.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: json.writer http.server.responses ;
+IN: furnace.json
+
+: <json-content> ( body -- response )
+    >json "application/json" <content> ;

extra/furnace/rss/rss.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel fry
+rss http.server.responses furnace.actions ;
+IN: furnace.rss
+
+: <feed-content> ( body -- response )
+    feed>xml "application/atom+xml" <content> ;
+
+TUPLE: feed-action < action feed ;
+
+: <feed-action> ( -- feed )
+    feed-action new-action
+        dup '[ , feed>> call <feed-content> ] >>display ;

extra/furnace/sessions/sessions-tests.factor

@@ -1,8 +1,10 @@
 IN: furnace.sessions.tests
 USING: tools.test http furnace.sessions
-furnace.actions http.server math namespaces kernel accessors
+furnace.actions http.server http.server.responses
+math namespaces kernel accessors
 prettyprint io.streams.string io.files splitting destructors
-sequences db db.sqlite continuations urls ;
+sequences db db.sqlite continuations urls math.parser
+furnace ;
 
 : with-session
     [

extra/furnace/sessions/sessions.factor

@@ -4,7 +4,8 @@ USING: assocs kernel math.intervals math.parser namespaces
 random accessors quotations hashtables sequences continuations
 fry calendar combinators destructors alarms
 db db.tuples db.types
-http http.server html.elements html.templates.chloe ;
+http http.server http.server.dispatchers http.server.filters
+html.elements furnace ;
 IN: furnace.sessions
 
 TUPLE: session id expires uid namespace changed? ;
@@ -151,11 +152,3 @@ M: sessions call-responder* ( path responder -- response )
 
 : logout-all-sessions ( uid -- )
     session new swap >>uid delete-tuples ;
-
-M: sessions link-attr
-    drop
-    "session" optional-attr {
-        { "none" [ session off flow-id off ] }
-        { "current" [ ] }
-        { f [ ] }
-    } case ;

extra/html/elements/elements.factor

@@ -190,7 +190,7 @@ SYMBOL: html
     <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
         <head> <title> swap write </title> </head>
         <body> call </body>
-    </html> ;
+    </html> ; inline
 
 : render-error ( message -- )
     <span "error" =class span> escape-string write </span> ;

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

@@ -49,7 +49,7 @@ IN: html.templates.chloe.tests
     [
         [
             "test2" test-template call-template
-        ] "test3" test-template with-boilerplate
+        ] [ "test3" test-template ] with-boilerplate
     ] run-template
 ] unit-test
 
@@ -69,24 +69,6 @@ IN: html.templates.chloe.tests
     ] run-template
 ] unit-test
 
-SYMBOL: test6-aux?
-
-[ "True" ] [
-    [
-        test6-aux? on
-        "test6" test-template call-template
-    ] run-template
-] unit-test
-
-SYMBOL: test7-aux?
-
-[ "" ] [
-    [
-        test7-aux? off
-        "test7" test-template call-template
-    ] run-template
-] unit-test
-
 [ ] [ blank-values ] unit-test
 
 [ ] [ "A label" "label" set-value ] unit-test
@@ -127,7 +109,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
 
 [ "<ul><li>1</li><li>2</li><li>3</li></ul>" ] [
     [
-        "test9" test-template call-template
+        "test7" test-template call-template
     ] run-template [ blank? not ] filter
 ] unit-test
 
@@ -142,7 +124,7 @@ TUPLE: person first-name last-name ;
 
 [ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
     [
-        "test10" test-template call-template
+        "test8" test-template call-template
     ] run-template [ blank? not ] filter
 ] unit-test
 
@@ -155,7 +137,7 @@ TUPLE: person first-name last-name ;
 
 [ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
     [
-        "test10" test-template call-template
+        "test9" test-template call-template
     ] run-template [ blank? not ] filter
 ] unit-test
 
@@ -163,6 +145,6 @@ TUPLE: person first-name last-name ;
 
 [ "<a name=\"1\">Hello</a>" ] [
     [
-        "test11" test-template call-template
+        "test10" test-template call-template
     ] run-template
 ] unit-test

extra/html/templates/chloe/chloe.factor

@@ -12,6 +12,7 @@ html.templates.chloe.syntax ;
 IN: html.templates.chloe
 
 ! Chloe is Ed's favorite web designer
+SYMBOL: tag-stack
 
 TUPLE: chloe path ;
 
@@ -44,7 +45,8 @@ CHLOE: title children>string set-title ;
 
 CHLOE: write-title
     drop
-    "head" tags get member? "title" tags get member? not and
+    "head" tag-stack get member?
+    "title" tag-stack get member? not and
     [ <title> write-title </title> ] [ write-title ] if ;
 
 CHLOE: style
@@ -92,22 +94,23 @@ CHLOE-SINGLETON: html
 CHLOE-SINGLETON: hidden
 
 CHLOE-TUPLE: field
+CHLOE-TUPLE: textarea
 CHLOE-TUPLE: password
 CHLOE-TUPLE: choice
 CHLOE-TUPLE: checkbox
 CHLOE-TUPLE: code
 
 : process-chloe-tag ( tag -- )
-    dup name-tag tags get at
+    dup name-tag dup tags get at
     [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
 
 : process-tag ( tag -- )
     {
-        [ name-tag >lower tags get push ]
+        [ name-tag >lower tag-stack get push ]
         [ write-start-tag ]
         [ process-tag-children ]
         [ write-end-tag ]
-        [ drop tags get pop* ]
+        [ drop tag-stack get pop* ]
     } cleave ;
 
 : expand-attrs ( tag -- tag )
@@ -127,7 +130,7 @@ CHLOE-TUPLE: code
 
 : process-chloe ( xml -- )
     [
-        V{ } clone tags set
+        V{ } clone tag-stack set
 
         nested-template? get [
             process-template

extra/html/templates/chloe/syntax/syntax.factor

@@ -14,11 +14,10 @@ SYMBOL: tags
 
 tags global [ H{ } clone or ] change-at
 
-: define-chloe-tag ( name quot -- ) tags get set-at ;
+: define-chloe-tag ( name quot -- ) swap tags get set-at ;
 
 : CHLOE:
-    scan parse-definition swap define-chloe-tag ;
+    scan parse-definition define-chloe-tag ; parsing
-    parsing
 
 : chloe-ns "http://factorcode.org/chloe/1.0" ; inline
 
@@ -38,7 +37,9 @@ MEMO: chloe-name ( string -- name )
     [ "name" required-attr ] dip render ;
 
 : CHLOE-SINGLETON:
-    scan dup '[ , singleton-component-tag ] define-chloe-tag ;
+    scan-word
+    [ word-name ] [ '[ , singleton-component-tag ] ] bi
+    define-chloe-tag ;
     parsing
 
 : attrs>slots ( tag tuple -- )
@@ -54,5 +55,7 @@ MEMO: chloe-name ( string -- name )
     2bi render ;
 
 : CHLOE-TUPLE:
-    scan dup '[ , tuple-component-tag ] define-chloe-tag ;
+    scan-word
+    [ word-name ] [ '[ , tuple-component-tag ] ] bi
+    define-chloe-tag ;
     parsing

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

@@ -2,8 +2,26 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:if t:var="html.templates.chloe.tests:test6-aux?">
+	<t:label t:name="label" />
-		True
+
-	</t:if>
+	<t:link t:name="link" />
+
+	<t:code t:name="code" mode="mode" />
+
+	<t:farkup t:name="farkup" />
+
+	<t:inspector t:name="inspector" />
+
+	<t:html t:name="html" />
+
+	<t:field t:name="field" t:size="13" />
+
+	<t:password t:name="password" t:size="10" />
+
+	<t:textarea t:name="textarea" t:rows="5" t:cols="10" />
+
+	<t:choice t:name="choice" t:choices="choices" />
+
+	<t:checkbox t:name="checkbox">Checkbox</t:checkbox>
 
 </t:chloe>

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

@@ -2,8 +2,10 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:if t:var="html.templates.chloe.tests:test7-aux?">
+	<ul>
-		True
+		<t:each t:name="numbers">
-	</t:if>
+			<li><t:label t:name="value"/></li>
+		</t:each>
+	</ul>
 
 </t:chloe>

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

@@ -2,26 +2,13 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:label t:name="label" />
+	<table>
-
+		<t:bind-each t:name="people">
-	<t:link t:name="link" />
+			<tr>
-
+				<td><t:label t:name="first-name"/></td>
-	<t:code t:name="code" mode="mode" />
+				<td><t:label t:name="last-name"/></td>
-
+			</tr>
-	<t:farkup t:name="farkup" />
+		</t:bind-each>
-
+	</table>
-	<t:inspector t:name="inspector" />
-
-	<t:html t:name="html" />
-
-	<t:field t:name="field" t:size="13" />
-
-	<t:password t:name="password" t:size="10" />
-
-	<t:textarea t:name="textarea" t:rows="5" t:cols="10" />
-
-	<t:choice t:name="choice" t:choices="choices" />
-
-	<t:checkbox t:name="checkbox">Checkbox</t:checkbox>
 
 </t:chloe>

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

@@ -1,11 +1,3 @@
 <?xml version='1.0' ?>
 
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><a name="@id">Hello</a></t:chloe>
-
-	<ul>
-		<t:each t:name="numbers">
-			<li><t:label t:name="value"/></li>
-		</t:each>
-	</ul>
-
-</t:chloe>

extra/http/client/client-tests.factor

@@ -10,30 +10,26 @@ tuple-syntax namespaces urls ;
 
 [
     TUPLE{ request
-        url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" query: H{ } }
+        url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" }
         method: "GET"
         version: "1.1"
         cookies: V{ }
         header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
     }
 ] [
-    [
+    "http://www.apple.com/index.html"
-        "http://www.apple.com/index.html"
+    <get-request>
-        <get-request>
-    ] with-scope
 ] unit-test
 
 [
     TUPLE{ request
-        url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" query: H{ } }
+        url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" }
         method: "GET"
         version: "1.1"
         cookies: V{ }
         header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
     }
 ] [
-    [
+    "https://www.amazon.com/index.html"
-        "https://www.amazon.com/index.html"
+    <get-request>
-        <get-request>
-    ] with-scope
 ] unit-test

extra/http/client/client.factor

@@ -4,7 +4,7 @@ USING: assocs http kernel math math.parser namespaces sequences
 io io.sockets io.streams.string io.files io.timeouts strings
 splitting calendar continuations accessors vectors math.order
 io.encodings.8-bit io.encodings.binary io.streams.duplex
-fry debugger inspector ascii ;
+fry debugger inspector ascii urls ;
 IN: http.client
 
 : max-redirects 10 ;
@@ -21,13 +21,16 @@ DEFER: http-request
 
 SYMBOL: redirects
 
+: redirect-url ( request url -- request )
+    '[ , >url derive-url ensure-port ] change-url ;
+
 : do-redirect ( response data -- response data )
     over code>> 300 399 between? [
         drop
         redirects inc
         redirects get max-redirects < [
             request get
-            swap "location" header request-with-url
+            swap "location" header redirect-url
             "GET" >>method http-request
         ] [
             too-many-redirects
@@ -61,8 +64,8 @@ PRIVATE>
 
 : <get-request> ( url -- request )
     <request>
-        swap request-with-url
+        "GET" >>method
-        "GET" >>method ;
+        swap >url ensure-port >>url ;
 
 : http-get* ( url -- response data )
     <get-request> http-request ;
@@ -100,7 +103,7 @@ M: download-failed error.
 : <post-request> ( content-type content url -- request )
     <request>
         "POST" >>method
-        swap request-with-url
+        swap >url ensure-port >>url
         swap >>post-data
         swap >>post-data-type ;
 

extra/http/http-tests.factor

@@ -3,11 +3,6 @@ io.streams.string kernel arrays splitting sequences
 assocs io.sockets db db.sqlite continuations urls ;
 IN: http.tests
 
-[ "/" ] [ "http://foo.com" url>path ] unit-test
-[ "/" ] [ "http://foo.com/" url>path ] unit-test
-[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
-[ "/bar" ] [ "/bar" url>path ] unit-test
-
 : lf>crlf "\n" split "\r\n" join ;
 
 STRING: read-request-test-1
@@ -126,7 +121,9 @@ read-response-test-1' 1array [
 USING: http.server http.server.static furnace.sessions
 furnace.actions furnace.auth.login furnace.db http.client
 io.server io.files io io.encodings.ascii
-accessors namespaces threads ;
+accessors namespaces threads
+http.server.responses http.server.redirection
+http.server.dispatchers ;
 
 : add-quit-action
     <action>
@@ -149,7 +146,7 @@ test-db [
                 "resource:extra/http/test" <static> >>default
             "nested" add-responder
             <action>
-                [ URL" redirect-loop" <redirect> ] >>display
+                [ URL" redirect-loop" <temporary-redirect> ] >>display
             "redirect-loop" add-responder
         main-responder set
 

extra/http/http.factor

@@ -6,8 +6,7 @@ assocs sequences splitting sorting sets debugger
 strings vectors hashtables quotations arrays byte-arrays
 math.parser calendar calendar.format
 
-io io.streams.string io.encodings.utf8 io.encodings.string
+io io.server io.sockets.secure
-io.sockets io.sockets.secure io.server
 
 unicode.case unicode.categories qualified
 
@@ -17,22 +16,6 @@ EXCLUDE: fry => , ;
 
 IN: http
 
-: secure-protocol? ( protocol -- ? )
-    "https" = ;
-
-: url-addr ( url -- addr )
-    [ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
-    secure-protocol? [ <secure> ] when ;
-
-: protocol-port ( protocol -- port )
-    {
-        { "http" [ 80 ] }
-        { "https" [ 443 ] }
-    } case ;
-
-: ensure-port ( url -- url' )
-    dup protocol>> '[ , protocol-port or ] change-port ;
-
 : crlf "\r\n" write ;
 
 : add-header ( value key assoc -- )
@@ -167,19 +150,6 @@ cookies ;
         "close" "connection" set-header
         "Factor http.client vocabulary" "user-agent" set-header ;
 
-: chop-hostname ( str -- str' )
-    ":" split1 "//" ?head drop nip
-    CHAR: / over index over length or tail
-    dup empty? [ drop "/" ] when ;
-
-: url>path ( url -- path )
-    #! Technically, only proxies are meant to support hostnames
-    #! in HTTP requests, but IE sends these sometimes so we
-    #! just chop the hostname part.
-    url-decode
-    dup { "http://" "https://" } [ head? ] with contains?
-    [ chop-hostname ] when ;
-
 : read-method ( request -- request )
     " " read-until [ "Bad request: method" throw ] unless
     >>method ;
@@ -299,9 +269,6 @@ SYMBOL: max-post-request
     flush
     drop ;
 
-: request-with-url ( request url -- request )
-    '[ , >url derive-url ensure-port ] change-url ;
-
 GENERIC: write-response ( response -- )
 
 GENERIC: write-full-response ( request response -- )
@@ -406,7 +373,7 @@ body ;
 
 : <raw-response> ( -- response )
     raw-response new
-    "1.1" >>version ;
+        "1.1" >>version ;
 
 M: raw-response write-response ( respose -- )
     write-response-version

extra/http/server/dispatchers/dispatchers-tests.factor

@@ -0,0 +1,97 @@
+USING: http.server http.server.dispatchers http.server.responses
+tools.test kernel namespaces accessors io http math sequences
+assocs arrays classes words urls ;
+IN: http.server.dispatchers.tests
+
+\ find-responder must-infer
+\ http-error. must-infer
+
+TUPLE: mock-responder path ;
+
+C: <mock-responder> mock-responder
+
+M: mock-responder call-responder*
+    nip
+    path>> on
+    [ ] "text/plain" <content> ;
+
+: check-dispatch ( tag path -- ? )
+    V{ } clone responder-nesting set
+    over off
+    split-path
+    main-responder get call-responder
+    write-response get ;
+
+[
+    <dispatcher>
+        "foo" <mock-responder> "foo" add-responder
+        "bar" <mock-responder> "bar" add-responder
+        <dispatcher>
+            "123" <mock-responder> "123" add-responder
+            "default" <mock-responder> >>default
+        "baz" add-responder
+    main-responder set
+
+    [ "foo" ] [
+        { "foo" } main-responder get find-responder path>> nip
+    ] unit-test
+
+    [ "bar" ] [
+        { "bar" } main-responder get find-responder path>> nip
+    ] unit-test
+
+    [ t ] [ "foo" "foo" check-dispatch ] unit-test
+    [ f ] [ "foo" "bar" check-dispatch ] unit-test
+    [ t ] [ "bar" "bar" check-dispatch ] unit-test
+    [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test
+    [ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test
+    [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test
+    [ t ] [ "123" "baz/123" check-dispatch ] unit-test
+    [ t ] [ "123" "baz///123" check-dispatch ] unit-test
+
+] with-scope
+
+[
+    <dispatcher>
+        "default" <mock-responder> >>default
+    main-responder set
+
+    [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test
+] with-scope
+
+! Make sure path for default responder isn't chopped
+TUPLE: path-check-responder ;
+
+C: <path-check-responder> path-check-responder
+
+M: path-check-responder call-responder*
+    drop
+    >array "text/plain" <content> ;
+
+[ { "c" } ] [
+    V{ } clone responder-nesting set
+
+    { "b" "c" }
+    <dispatcher>
+        <dispatcher>
+            <path-check-responder> >>default
+        "b" add-responder
+    call-responder
+    body>>
+] unit-test
+
+! Test that "" dispatcher works with default>>
+[ ] [
+    <dispatcher>
+        "" <mock-responder> "" add-responder
+        "bar" <mock-responder> "bar" add-responder
+        "baz" <mock-responder> >>default
+    main-responder set
+
+    [ t ] [ "" "" check-dispatch ] unit-test
+    [ f ] [ "" "quux" check-dispatch ] unit-test
+    [ t ] [ "baz" "quux" check-dispatch ] unit-test
+    [ f ] [ "foo" "bar" check-dispatch ] unit-test
+    [ t ] [ "bar" "bar" check-dispatch ] unit-test
+    [ t ] [ "baz" "xxx" check-dispatch ] unit-test
+] unit-test

extra/http/server/dispatchers/dispatchers.factor

@@ -0,0 +1,47 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces sequences assocs accessors
+http http.server http.server.responses ;
+IN: http.server.dispatchers
+
+TUPLE: dispatcher default responders ;
+
+: new-dispatcher ( class -- dispatcher )
+    new
+        <404> <trivial-responder> >>default
+        H{ } clone >>responders ; inline
+
+: <dispatcher> ( -- dispatcher )
+    dispatcher new-dispatcher ;
+
+: find-responder ( path dispatcher -- path responder )
+    over empty? [
+        "" over responders>> at*
+        [ nip ] [ drop default>> ] if
+    ] [
+        over first over responders>> at*
+        [ [ drop rest-slice ] dip ] [ drop default>> ] if
+    ] if ;
+
+M: dispatcher call-responder* ( path dispatcher -- response )
+    find-responder call-responder ;
+
+TUPLE: vhost-dispatcher default responders ;
+
+: <vhost-dispatcher> ( -- dispatcher )
+    vhost-dispatcher new-dispatcher ;
+
+: find-vhost ( dispatcher -- responder )
+    request get url>> host>> over responders>> at*
+    [ nip ] [ drop default>> ] if ;
+
+M: vhost-dispatcher call-responder* ( path dispatcher -- response )
+    find-vhost call-responder ;
+
+: add-responder ( dispatcher responder path -- dispatcher )
+    pick responders>> set-at ;
+
+: add-main-responder ( dispatcher responder path -- dispatcher )
+    [ add-responder drop ]
+    [ drop "" add-responder drop ]
+    [ 2drop ] 3tri ;

extra/http/server/filters/filters.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: http.server accessors ;
+IN: http.server.filters
+
+TUPLE: filter-responder responder ;
+
+M: filter-responder call-responder*
+    responder>> call-responder ;

extra/http/server/redirection/redirection-tests.factor

@@ -0,0 +1,48 @@
+IN: http.server.redirection.tests
+USING: http http.server.redirection urls accessors
+namespaces tools.test ;
+
+\ relative-to-request must-infer
+
+[
+    <request>
+        <url>
+            "http" >>protocol
+            "www.apple.com" >>host
+            "/xxx/bar" >>path
+            { { "a" "b" } } >>query
+        >>url
+    request set
+
+    [ "http://www.apple.com:80/xxx/bar" ] [ 
+        <url> relative-to-request url>string 
+    ] unit-test
+
+    [ "http://www.apple.com:80/xxx/baz" ] [
+        <url> "baz" >>path relative-to-request url>string
+    ] unit-test
+    
+    [ "http://www.apple.com:80/xxx/baz?c=d" ] [
+        <url> "baz" >>path { { "c" "d" } } >>query relative-to-request url>string
+    ] unit-test
+    
+    [ "http://www.apple.com:80/xxx/bar?c=d" ] [
+        <url> { { "c" "d" } } >>query relative-to-request url>string
+    ] unit-test
+    
+    [ "http://www.apple.com:80/flip" ] [
+        <url> "/flip" >>path relative-to-request url>string
+    ] unit-test
+    
+    [ "http://www.apple.com:80/flip?c=d" ] [
+        <url> "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string
+    ] unit-test
+    
+    [ "http://www.jedit.org:80/" ] [
+        "http://www.jedit.org" >url relative-to-request url>string
+    ] unit-test
+    
+    [ "http://www.jedit.org:80/?a=b" ] [
+        "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request url>string
+    ] unit-test
+] with-scope

extra/http/server/redirection/redirection.factor

@@ -0,0 +1,24 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators namespaces
+logging urls http http.server http.server.responses ;
+IN: http.server.redirection
+
+: relative-to-request ( url -- url' )
+    request get url>>
+        clone
+        f >>query
+    swap derive-url ensure-port ;
+
+: <custom-redirect> ( url code message -- response )
+    <trivial-response>
+        swap dup url? [ relative-to-request ] when
+        "location" set-header ;
+
+\ <custom-redirect> DEBUG add-input-logging
+
+: <permanent-redirect> ( url -- response )
+    301 "Moved Permanently" <custom-redirect> ;
+
+: <temporary-redirect> ( url -- response )
+    307 "Temporary Redirect" <custom-redirect> ;

extra/http/server/responses/responses.factor

@@ -0,0 +1,37 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: html.elements math.parser http accessors kernel
+io io.streams.string ;
+IN: http.server.responses
+
+: <content> ( body content-type -- response )
+    <response>
+        200 >>code
+        "Document follows" >>message
+        swap >>content-type
+        swap >>body ;
+    
+: trivial-response-body ( code message -- )
+    <html>
+        <body>
+            <h1> [ number>string write bl ] [ write ] bi* </h1>
+        </body>
+    </html> ;
+
+: <trivial-response> ( code message -- response )
+    2dup [ trivial-response-body ] with-string-writer
+    "text/html" <content>
+        swap >>message
+        swap >>code ;
+
+: <304> ( -- response )
+    304 "Not modified" <trivial-response> ;
+
+: <403> ( -- response )
+    403 "Forbidden" <trivial-response> ;
+
+: <400> ( -- response )
+    400 "Bad request" <trivial-response> ;
+
+: <404> ( -- response )
+    404 "Not found" <trivial-response> ;

extra/http/server/server.factor

@@ -1,217 +1,51 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel namespaces io io.timeouts strings splitting
+USING: kernel accessors sequences arrays namespaces splitting
-threads sequences prettyprint io.server logging calendar http
+vocabs.loader http http.server.responses logging calendar
-html.streams html.components html.elements html.templates
+destructors html.elements html.streams io.server
-accessors math.parser combinators.lib tools.vocabs debugger
+io.encodings.8-bit io.timeouts io assocs debugger continuations
-continuations random combinators destructors io.streams.string
+fry tools.vocabs math ;
-io.encodings.8-bit fry classes words math urls
-arrays vocabs.loader ;
 IN: http.server
 
+SYMBOL: responder-nesting
+
+SYMBOL: main-responder
+
+SYMBOL: development-mode
+
 ! path is a sequence of path component strings
 GENERIC: call-responder* ( path responder -- response )
 
-: <content> ( body content-type -- response )
-    <response>
-        200 >>code
-        "Document follows" >>message
-        swap >>content-type
-        swap >>body ;
-
 TUPLE: trivial-responder response ;
 
 C: <trivial-responder> trivial-responder
 
-M: trivial-responder call-responder* nip response>> call ;
+M: trivial-responder call-responder* nip response>> clone ;
 
-: trivial-response-body ( code message -- )
+main-responder global [ <404> <trivial-responder> get-global or ] change-at
-    <html>
-        <body>
-            <h1> [ number>string write bl ] [ write ] bi* </h1>
-        </body>
-    </html> ;
-
-: <trivial-response> ( code message -- response )
-    2dup [ trivial-response-body ] with-string-writer
-    "text/html" <content>
-        swap >>message
-        swap >>code ;
-
-: <400> ( -- response )
-    400 "Bad request" <trivial-response> ;
-
-: <404> ( -- response )
-    404 "Not Found" <trivial-response> ;
-
-SYMBOL: 404-responder
-
-[ <404> ] <trivial-responder> 404-responder set-global
-
-SYMBOL: responder-nesting
 
 : invert-slice ( slice -- slice' )
-    dup slice? [
+    dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
-        [ seq>> ] [ from>> ] bi head-slice
-    ] [
-        drop { }
-    ] if ;
 
-: vocab-path ( vocab -- path )
+: add-responder-nesting ( path responder -- )
-    dup vocab-dir vocab-append-path ;
+    [ invert-slice ] dip 2array responder-nesting get push ;
-
-: vocab-path-of ( dispatcher -- path )
-    class word-vocabulary vocab-path ;
-
-: add-responder-path ( path dispatcher -- )
-    [ [ invert-slice ] [ [ vocab-path-of ] keep ] bi* 3array ]
-    [ nip class word-name ] 2bi
-    responder-nesting get set-at ;
 
 : call-responder ( path responder -- response )
-    [ add-responder-path ] [ call-responder* ] 2bi ;
+    [ add-responder-nesting ] [ call-responder* ] 2bi ;
-
-: nested-responders ( -- seq )
-    responder-nesting get assocs:values [ third ] map ;
-
-: each-responder ( quot -- )
-   nested-responders swap each ; inline
-
-: responder-path ( string -- pair )
-    dup responder-nesting get at
-    [ ] [ "No such responder: " swap append throw ] ?if ;
-
-: base-path ( string -- path )
-    responder-path first ;
-
-: template-path ( string -- path )
-    responder-path second ;
-
-: resolve-responder-path ( string quot -- string' )
-    [ "$" ?head ] dip '[
-        [
-            "/" split1 [ @ [ "/" % % ] each "/" % ] dip %
-        ] "" make
-    ] when ; inline
-
-: resolve-base-path ( string -- string' )
-    [ base-path ] resolve-responder-path ;
-
-: resolve-template-path ( string -- string' )
-    [ template-path ] resolve-responder-path ;
-
-GENERIC: modify-query ( query responder -- query' )
-
-M: object modify-query drop ;
-
-: adjust-url ( url -- url' )
-    clone
-        [ dup [ modify-query ] each-responder ] change-query
-        [ resolve-base-path ] change-path
-    request get url>>
-        clone
-        f >>query
-    swap derive-url ensure-port ;
-
-: <custom-redirect> ( url code message -- response )
-    <trivial-response>
-        swap dup url? [ adjust-url ] when
-        "location" set-header ;
-
-\ <custom-redirect> DEBUG add-input-logging
-
-: <permanent-redirect> ( to query -- response )
-    301 "Moved Permanently" <custom-redirect> ;
-
-: <temporary-redirect> ( to query -- response )
-    307 "Temporary Redirect" <custom-redirect> ;
-
-: <redirect> ( to query -- response )
-    request get method>> {
-        { "GET" [ <temporary-redirect> ] }
-        { "HEAD" [ <temporary-redirect> ] }
-        { "POST" [ <permanent-redirect> ] }
-    } case ;
-
-TUPLE: dispatcher default responders ;
-
-: new-dispatcher ( class -- dispatcher )
-    new
-        404-responder get >>default
-        H{ } clone >>responders ; inline
-
-: <dispatcher> ( -- dispatcher )
-    dispatcher new-dispatcher ;
-
-: find-responder ( path dispatcher -- path responder )
-    over empty? [
-        "" over responders>> at*
-        [ nip ] [ drop default>> ] if
-    ] [
-        over first over responders>> at*
-        [ [ drop rest-slice ] dip ] [ drop default>> ] if
-    ] if ;
-
-M: dispatcher call-responder* ( path dispatcher -- response )
-    find-responder call-responder ;
-
-TUPLE: vhost-dispatcher default responders ;
-
-: <vhost-dispatcher> ( -- dispatcher )
-    404-responder get H{ } clone vhost-dispatcher boa ;
-
-: find-vhost ( dispatcher -- responder )
-    request get url>> host>> over responders>> at*
-    [ nip ] [ drop default>> ] if ;
-
-M: vhost-dispatcher call-responder* ( path dispatcher -- response )
-    find-vhost call-responder ;
-
-: add-responder ( dispatcher responder path -- dispatcher )
-    pick responders>> set-at ;
-
-: add-main-responder ( dispatcher responder path -- dispatcher )
-    [ add-responder drop ]
-    [ drop "" add-responder drop ]
-    [ 2drop ] 3tri ;
-
-TUPLE: filter-responder responder ;
-
-M: filter-responder call-responder*
-    responder>> call-responder ;
-
-SYMBOL: main-responder
-
-main-responder global
-[ drop 404-responder get-global ] cache
-drop
-
-SYMBOL: development-mode
 
 : http-error. ( error -- )
     "Internal server error" [
-        development-mode get [
+        [ print-error nl :c ] with-html-stream
-            [ print-error nl :c ] with-html-stream
-        ] [
-            500 "Internal server error"
-            trivial-response-body
-        ] if
     ] simple-page ;
 
 : <500> ( error -- response )
     500 "Internal server error" <trivial-response>
-    swap '[ , http-error. ] >>body ;
+    development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ;
 
 : do-response ( response -- )
     dup write-response
     request get method>> "HEAD" =
-    [ drop ] [
+    [ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ;
-        '[
-            , write-response-body
-        ] [
-            http-error.
-        ] recover
-    ] if ;
 
 LOG: httpd-hit NOTICE
 
@@ -223,9 +57,7 @@ LOG: httpd-hit NOTICE
 
 : init-request ( request -- )
     request set
-    H{ } clone responder-nesting set
+    V{ } clone responder-nesting set ;
-    [ ] link-hook set
-    [ ] form-hook set ;
 
 : dispatch-request ( request -- response )
     url>> path>> split-path main-responder get call-responder ;
@@ -235,9 +67,7 @@ LOG: httpd-hit NOTICE
         [ init-request ]
         [ log-request ]
         [ dispatch-request ] tri
-    ]
+    ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
-    [ [ \ do-request log-error ] [ <500> ] bi ]
-    recover ;
 
 : ?refresh-all ( -- )
     development-mode get-global
@@ -254,8 +84,7 @@ LOG: httpd-hit NOTICE
 
 : httpd ( port -- )
     dup integer? [ internet-server ] when
-    "http.server" latin1
+    "http.server" latin1 [ handle-client ] with-server ;
-    [ handle-client ] with-server ;
 
 : httpd-main ( -- )
     8888 httpd ;

extra/http/server/static/static.factor

@@ -1,10 +1,15 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: calendar io io.files kernel math math.order
-math.parser http http.server namespaces parser sequences strings
+math.parser namespaces parser sequences strings
-assocs hashtables debugger http.mime sorting html.elements
+assocs hashtables debugger mime-types sorting logging
-html.templates.fhtml logging calendar.format accessors
+calendar.format accessors
-io.encodings.binary fry xml.entities destructors urls ;
+io.encodings.binary fry xml.entities destructors urls
+html.elements html.templates.fhtml
+http
+http.server
+http.server.responses
+http.server.redirection ;
 IN: http.server.static
 
 ! special maps mime types to quots with effect ( path -- )
@@ -17,12 +22,6 @@ TUPLE: file-responder root hook special allow-listings ;
         2drop t
     ] if ;
 
-: <304> ( -- response )
-    304 "Not modified" <trivial-response> ;
-
-: <403> ( -- response )
-    403 "Forbidden" <trivial-response> ;
-
 : <file-responder> ( root hook -- responder )
     file-responder new
         swap >>hook
@@ -85,7 +84,7 @@ TUPLE: file-responder root hook special allow-listings ;
         find-index [ serve-file ] [ list-directory ] ?if
     ] [
         drop
-        request get url>> clone [ "/" append ] change-path <redirect>
+        request get url>> clone [ "/" append ] change-path <permanent-redirect>
     ] if ;
 
 : serve-object ( filename -- response )

extra/urls/urls.factor

@@ -94,10 +94,10 @@ TUPLE: url protocol username password host port path query anchor ;
 
 : <url> ( -- url ) url new ;
 
-: query-param ( request key -- value )
+: query-param ( url key -- value )
     swap query>> at ;
 
-: set-query-param ( request value key -- request )
+: set-query-param ( url value key -- url )
     '[ , , _ ?set-at ] change-query ;
 
 : parse-host ( string -- host port )

extra/webapps/counter/counter.factor

@@ -19,7 +19,7 @@ M: counter-app init-session* drop 0 count sset ;
 : <display-action> ( -- action )
     <page-action>
         [ count sget "counter" set-value ] >>init
-        "$counter-app/counter" >>template ;
+        { counter-app "counter" } >>template ;
 
 : <counter-app> ( -- responder )
     counter-app new-dispatcher

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

@@ -4,6 +4,7 @@ USING: accessors kernel sequences assocs io.files io.sockets
 io.server
 namespaces db db.sqlite smtp
 http.server
+http.server.dispatchers
 furnace.db
 furnace.flows
 furnace.sessions
@@ -51,7 +52,7 @@ TUPLE: factor-website < dispatcher ;
         allow-password-recovery
         allow-edit-profile
     <boilerplate>
-        "$factor-website/page" >>template
+        { factor-website "page" } >>template
     <flows>
     <sessions>
     test-db <db-persistence> ;

extra/webapps/pastebin/pastebin-common.xml

@@ -11,9 +11,9 @@
 		  <t:a t:href="$pastebin/list">Pastes</t:a>
 		| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
 
-		<t:if t:code="http.server.sessions:uid">
+		<t:if t:code="furnace.sessions:uid">
 
-			<t:if t:code="http.server.auth.login:allow-edit-profile?">
+			<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:if>
 

extra/webapps/pastebin/pastebin.factor

@@ -3,14 +3,22 @@
 USING: namespaces assocs sorting sequences kernel accessors
 hashtables sequences.lib db.types db.tuples db combinators
 calendar calendar.format math.parser rss urls xml.writer
-xmode.catalog validators html.components html.templates.chloe
+xmode.catalog validators
+html.components
+html.templates.chloe
 http.server
+http.server.dispatchers
+http.server.redirection
+furnace
 furnace.actions
 furnace.auth
 furnace.auth.login
-furnace.boilerplate ;
+furnace.boilerplate
+furnace.rss ;
 IN: webapps.pastebin
 
+TUPLE: pastebin < dispatcher ;
+
 ! ! !
 ! DOMAIN MODEL
 ! ! !
@@ -91,7 +99,7 @@ M: annotation entity-link
 : <pastebin-action> ( -- action )
     <page-action>
         [ pastes "pastes" set-value ] >>init
-        "$pastebin/pastebin" >>template ;
+        { pastebin "pastebin" } >>template ;
 
 : pastebin-feed-entries ( seq -- entries )
     <reversed> 20 short head [
@@ -99,7 +107,7 @@ M: annotation entity-link
             swap
             [ summary>> >>title ]
             [ date>> >>pub-date ]
-            [ entity-link adjust-url >>link ]
+            [ entity-link adjust-url relative-to-request >>link ]
             tri
     ] map ;
 
@@ -130,7 +138,7 @@ M: annotation entity-link
             ] nest-values
         ] >>init
 
-        "$pastebin/paste" >>template ;
+        { pastebin "paste" } >>template ;
 
 : paste-feed-entries ( paste -- entries )
     fetch-annotations annotations>> pastebin-feed-entries ;
@@ -139,7 +147,7 @@ M: annotation entity-link
     feed new
         swap
         [ "Paste " swap id>> number>string append >>title ]
-        [ entity-link adjust-url >>link ]
+        [ entity-link adjust-url relative-to-request >>link ]
         [ paste-feed-entries >>entries ]
         tri ;
 
@@ -168,7 +176,9 @@ M: annotation entity-link
             mode-names "modes" set-value
         ] >>init
 
-        "$pastebin/new-paste" >>template
+        { pastebin "new-paste" } >>template
+
+        [ mode-names "modes" set-value ] >>validate
 
         [
             validate-entity
@@ -225,8 +235,6 @@ M: annotation entity-link
             bi
         ] >>submit ;
 
-TUPLE: pastebin < dispatcher ;
-
 SYMBOL: can-delete-pastes?
 
 can-delete-pastes? define-capability
@@ -242,7 +250,7 @@ can-delete-pastes? define-capability
         <new-annotation-action> "new-annotation" add-responder
         <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
     <boilerplate>
-        "$pastebin/pastebin-common" >>template ;
+        { pastebin "pastebin-common" } >>template ;
 
 : init-pastes-table \ paste ensure-table ;
 

extra/webapps/planet/entry-summary.xml

@@ -4,7 +4,7 @@
 
 	<p class="news">
 		<strong><t:view t:component="title" /></strong> <br/>
-		<t:a value="link" t:session="none" class="more">Read More...</t:a>
+		<t:a value="link" class="more">Read More...</t:a>
 	</p>
 
 </t:chloe>

extra/webapps/planet/entry.xml

@@ -3,7 +3,7 @@
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
 	<h2 class="posting-title">
-		<t:a t:value="link" t:session="none"><t:view t:component="title" /></t:a>
+		<t:a t:value="link"><t:view t:component="title" /></t:a>
 	</h2>
 
 	<p class="posting-body">
@@ -11,7 +11,7 @@
 	</p>
 
 	<p class="posting-date">
-		<t:a t:value="link" t:session="none"><t:view t:component="pub-date" /></t:a>
+		<t:a t:value="link"><t:view t:component="pub-date" /></t:a>
 	</p>
 
 </t:chloe>

extra/webapps/planet/mini-planet.xml

@@ -6,7 +6,7 @@
 
 		<p class="news">
 			<strong><t:view t:component="title" /></strong> <br/>
-			<t:a value="link" t:session="none" class="more">Read More...</t:a>
+			<t:a value="link" class="more">Read More...</t:a>
 		</p>
 
 	</t:bind-each>

extra/webapps/planet/planet-common.xml

@@ -9,8 +9,8 @@
 		| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
 		| <t:a t:href="$planet-factor/admin">Admin</t:a>
 
-		<t:if t:code="http.server.sessions:uid">
+		<t:if t:code="furnace.sessions:uid">
-			<t:if t:code="http.server.auth.login:allow-edit-profile?">
+			<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:if>
 	

extra/webapps/planet/planet.factor

@@ -7,12 +7,19 @@ html.components
 rss urls xml.writer
 validators
 http.server
+http.server.dispatchers
+furnace
 furnace.actions
 furnace.boilerplate
 furnace.auth.login
-furnace.auth ;
+furnace.auth
+furnace.rss ;
 IN: webapps.planet
 
+TUPLE: planet-factor < dispatcher ;
+
+TUPLE: planet-factor-admin < dispatcher ;
+
 TUPLE: blog id name www-url feed-url ;
 
 M: blog link-title name>> ;
@@ -58,7 +65,7 @@ posting "POSTINGS"
 : <edit-blogroll-action> ( -- action )
     <page-action>
         [ blogroll "blogroll" set-value ] >>init
-        "$planet-factor/admin" >>template ;
+        { planet-factor "admin" } >>template ;
 
 : <planet-action> ( -- action )
     <page-action>
@@ -67,7 +74,7 @@ posting "POSTINGS"
             postings "postings" set-value
         ] >>init
 
-        "$planet-factor/planet" >>template ;
+        { planet-factor "planet" } >>template ;
 
 : planet-feed ( -- feed )
     feed new
@@ -131,7 +138,7 @@ posting "POSTINGS"
 
 : <new-blog-action> ( -- action )
     <page-action>
-        "$planet-factor/new-blog" >>template
+        { planet-factor "new-blog" } >>template
 
         [ validate-blog ] >>validate
 
@@ -155,7 +162,7 @@ posting "POSTINGS"
             "id" value <blog> select-tuple from-object
         ] >>init
 
-        "$planet-factor/edit-blog" >>template
+        { planet-factor "edit-blog" } >>template
 
         [
             validate-integer-id
@@ -175,8 +182,6 @@ posting "POSTINGS"
             tri
         ] >>submit ;
 
-TUPLE: planet-factor-admin < dispatcher ;
-
 : <planet-factor-admin> ( -- responder )
     planet-factor-admin new-dispatcher
         <edit-blogroll-action> "blogroll" add-main-responder
@@ -189,15 +194,13 @@ SYMBOL: can-administer-planet-factor?
 
 can-administer-planet-factor? define-capability
 
-TUPLE: planet-factor < dispatcher ;
-
 : <planet-factor> ( -- responder )
     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
     <boilerplate>
-        "$planet-factor/planet-common" >>template ;
+        { planet-factor "planet-common" } >>template ;
 
 : start-update-task ( db params -- )
     '[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;

extra/webapps/planet/planet.xml

@@ -11,7 +11,7 @@
 				<t:bind-each t:name="postings">
 
 					<h2 class="posting-title">
-						<t:a t:value="link" t:session="none"><t:label t:name="title" /></t:a>
+						<t:a t:value="link"><t:label t:name="title" /></t:a>
 					</h2>
 
 					<p class="posting-body">
@@ -19,7 +19,7 @@
 					</p>
 
 					<p class="posting-date">
-						<t:a t:value="link" t:session="none"><t:label t:name="pub-date" /></t:a>
+						<t:a t:value="link"><t:label t:name="pub-date" /></t:a>
 					</p>
 
 				</t:bind-each>

extra/webapps/todo/todo.factor

@@ -4,15 +4,19 @@ USING: accessors kernel sequences namespaces
 db db.types db.tuples validators hashtables urls
 html.components
 html.templates.chloe
+http.server
+http.server.dispatchers
+furnace
 furnace.sessions
 furnace.boilerplate
 furnace.auth
 furnace.actions
 furnace.db
-furnace.auth.login
+furnace.auth.login ;
-http.server ;
 IN: webapps.todo
 
+TUPLE: todo-list < dispatcher ;
+
 TUPLE: todo uid id priority summary description ;
 
 todo "TODO"
@@ -38,7 +42,7 @@ todo "TODO"
             "id" value <todo> select-tuple from-object
         ] >>init
         
-        "$todo-list/view-todo" >>template ;
+        { todo-list "view-todo" } >>template ;
 
 : validate-todo ( -- )
     {
@@ -51,7 +55,7 @@ todo "TODO"
     <page-action>
         [ 0 "priority" set-value ] >>init
 
-        "$todo-list/new-todo" >>template
+        { todo-list "new-todo" } >>template
 
         [ validate-todo ] >>validate
 
@@ -75,7 +79,7 @@ todo "TODO"
             "id" value <todo> select-tuple from-object
         ] >>init
 
-        "$todo-list/edit-todo" >>template
+        { todo-list "edit-todo" } >>template
 
         [
             validate-integer-id
@@ -107,9 +111,7 @@ todo "TODO"
 : <list-action> ( -- action )
     <page-action>
         [ f <todo> select-tuples "items" set-value ] >>init
-        "$todo-list/todo-list" >>template ;
+        { todo-list "todo-list" } >>template ;
-
-TUPLE: todo-list < dispatcher ;
 
 : <todo-list> ( -- responder )
     todo-list new-dispatcher
@@ -119,5 +121,5 @@ TUPLE: todo-list < dispatcher ;
         <edit-action>   "edit"   add-responder
         <delete-action> "delete" add-responder
     <boilerplate>
-        "$todo-list/todo" >>template
+        { todo-list "todo" } >>template
     f <protected> ;

extra/webapps/todo/todo.xml

@@ -8,7 +8,7 @@
 		  <t:a t:href="$todo-list/list">List Items</t:a>
 		| <t:a t:href="$todo-list/new">Add Item</t:a>
 
-		<t:if t:code="http.server.auth.login:allow-edit-profile?">
+		<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:if>
 

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

@@ -4,6 +4,7 @@ USING: kernel sequences accessors namespaces combinators words
 assocs db.tuples arrays splitting strings validators urls
 html.elements
 html.components
+furnace
 furnace.boilerplate
 furnace.auth.providers
 furnace.auth.providers.db
@@ -11,9 +12,12 @@ furnace.auth.login
 furnace.auth
 furnace.sessions
 furnace.actions
-http.server ;
+http.server
+http.server.dispatchers ;
 IN: webapps.user-admin
 
+TUPLE: user-admin < dispatcher ;
+
 : word>string ( word -- string )
     [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
 
@@ -29,7 +33,7 @@ IN: webapps.user-admin
 : <user-list-action> ( -- action )
     <page-action>
         [ f <user> select-tuples "users" set-value ] >>init
-        "$user-admin/user-list" >>template ;
+        { user-admin "user-list" } >>template ;
 
 : init-capabilities ( -- )
     capabilities get words>strings "capabilities" set-value ;
@@ -46,7 +50,7 @@ IN: webapps.user-admin
             init-capabilities
         ] >>init
 
-        "$user-admin/new-user" >>template
+        { user-admin "new-user" } >>template
 
         [
             init-capabilities
@@ -94,7 +98,7 @@ IN: webapps.user-admin
             capabilities get words>strings "capabilities" set-value
         ] >>init
 
-        "$user-admin/edit-user" >>template
+        { user-admin "edit-user" } >>template
 
         [
             init-capabilities
@@ -140,8 +144,6 @@ IN: webapps.user-admin
             URL" $user-admin" <redirect>
         ] >>submit ;
 
-TUPLE: user-admin < dispatcher ;
-
 SYMBOL: can-administer-users?
 
 can-administer-users? define-capability
@@ -153,7 +155,7 @@ can-administer-users? define-capability
         <edit-user-action> "edit" add-responder
         <delete-user-action> "delete" add-responder
     <boilerplate>
-        "$user-admin/user-admin" >>template
+        { user-admin "user-admin" } >>template
     { can-administer-users? } <protected> ;
 
 : make-admin ( username -- )

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

@@ -6,7 +6,7 @@
 		  <t:a t:href="$user-admin">List Users</t:a>
 		| <t:a t:href="$user-admin/new">Add User</t:a>
 
-		<t:if t:code="http.server.auth.login:allow-edit-profile?">
+		<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:if>
 

extra/webapps/wiki/wiki-common.xml

@@ -10,9 +10,9 @@
 		| <t:a t:href="$wiki/articles">All Articles</t:a>
 		| <t:a t:href="$wiki/changes">Recent Changes</t:a>
 
-		<t:if t:code="http.server.sessions:uid">
+		<t:if t:code="furnace.sessions:uid">
 
-			<t:if t:code="http.server.auth.login:allow-edit-profile?">
+			<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:if>
 

extra/webapps/wiki/wiki.factor

@@ -4,6 +4,8 @@ USING: accessors kernel hashtables calendar
 namespaces splitting sequences sorting math.order
 html.components
 http.server
+http.server.dispatchers
+furnace
 furnace.actions
 furnace.auth
 furnace.auth.login
@@ -12,6 +14,8 @@ validators
 db.types db.tuples lcs farkup urls ;
 IN: webapps.wiki
 
+TUPLE: wiki < dispatcher ;
+
 TUPLE: article title revision ;
 
 article "ARTICLES" {
@@ -64,7 +68,7 @@ revision "REVISIONS" {
         [
             "title" value dup <article> select-tuple [
                 revision>> <revision> select-tuple from-object
-                "$wiki/view" <chloe-content>
+                { wiki "view" } <chloe-content>
             ] [
                 <url>
                     "$wiki/edit" >>path
@@ -81,7 +85,7 @@ revision "REVISIONS" {
             select-tuple from-object
         ] >>init
 
-        "$wiki/view" >>template ;
+        { wiki "view" } >>template ;
 
 : add-revision ( revision -- )
     [ insert-tuple ]
@@ -102,7 +106,7 @@ revision "REVISIONS" {
             ] when*
         ] >>init
 
-        "$wiki/edit" >>template
+        { wiki "edit" } >>template
         
         [
             validate-title
@@ -131,7 +135,7 @@ revision "REVISIONS" {
             "revisions" set-value
         ] >>init
 
-        "$wiki/revisions" >>template ;
+        { wiki "revisions" } >>template ;
 
 : <rollback-action> ( -- action )
     <action>
@@ -158,7 +162,7 @@ revision "REVISIONS" {
             "changes" set-value
         ] >>init
 
-        "$wiki/changes" >>template ;
+        { wiki "changes" } >>template ;
 
 : <delete-action> ( -- action )
     <action>
@@ -185,7 +189,7 @@ revision "REVISIONS" {
             2bi
         ] >>init
 
-        "$wiki/diff" >>template ;
+        { wiki "diff" } >>template ;
 
 : <list-articles-action> ( -- action )
     <page-action>
@@ -195,7 +199,7 @@ revision "REVISIONS" {
             "articles" set-value
         ] >>init
 
-        "$wiki/articles" >>template ;
+        { wiki "articles" } >>template ;
 
 : <user-edits-action> ( -- action )
     <page-action>
@@ -205,9 +209,7 @@ revision "REVISIONS" {
             select-tuples "user-edits" set-value
         ] >>init
 
-        "$wiki/user-edits" >>template ;
+        { wiki "user-edits" } >>template ;
-
-TUPLE: wiki < dispatcher ;
 
 : <wiki> ( -- dispatcher )
     wiki new-dispatcher
@@ -223,4 +225,4 @@ TUPLE: wiki < dispatcher ;
         <edit-article-action> { } <protected> "edit" add-responder
         <delete-action> { } <protected> "delete" add-responder
     <boilerplate>
-        "$wiki/wiki-common" >>template ;
+        { wiki "wiki-common" } >>template ;

unmaintained/cont-responder/callbacks-tests.factor

@@ -1,13 +1,12 @@
-IN: furnace.callbacks
+USING: furnace furnace.actions furnace.callbacks accessors
-USING: furnace.actions furnace.callbacks accessors
+http http.server http.server.responses tools.test
-http.server http tools.test namespaces io fry sequences
+namespaces io fry sequences
 splitting kernel hashtables continuations ;
+IN: furnace.callbacks.tests
 
 [ 123 ] [
     [
-        init-request
+        <request> "GET" >>method init-request
-
-        <request> "GET" >>method request set
         [
             exit-continuation set
             { }
@@ -19,8 +18,6 @@ splitting kernel hashtables continuations ;
 ] unit-test
 
 [
-    init-request
-
     <action> [
         [
             "hello" print
@@ -32,9 +29,11 @@ splitting kernel hashtables continuations ;
     <callback-responder> "r" set
 
     [ 123 ] [
+        <request> init-request
+
         [
             exit-continuation set
-            <request> "GET" >>method request set
+            <request> "GET" >>method init-request
             { } "r" get call-responder
         ] callcc1
 
@@ -42,9 +41,9 @@ splitting kernel hashtables continuations ;
 
         <request>
             "GET" >>method
-            swap cont-id associate >>query
+            dup url>> rot cont-id associate >>query drop
-            "/" >>path
+            dup url>> "/" >>path drop
-        request set
+        init-request
 
         [
             exit-continuation set
@@ -55,9 +54,9 @@ splitting kernel hashtables continuations ;
         ! get-post-get
         <request>
             "GET" >>method
-            swap "location" header "=" last-split1 nip cont-id associate >>query
+            dup url>> rot "location" header query>> >>query drop
-            "/" >>path
+            dup url>> "/" >>path drop
-        request set
+        init-request
 
         [
             exit-continuation set

unmaintained/cont-responder/callbacks.factor

@@ -3,7 +3,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: http http.server io kernel math namespaces
 continuations calendar sequences assocs hashtables
-accessors arrays alarms quotations combinators fry assocs.lib ;
+accessors arrays alarms quotations combinators fry
+http.server.redirection furnace assocs.lib urls ;
 IN: furnace.callbacks
 
 SYMBOL: responder
@@ -11,9 +12,6 @@ SYMBOL: responder
 TUPLE: callback-responder responder callbacks ;
 
 : <callback-responder> ( responder -- responder' )
-    #! A continuation responder is a special type of session
-    #! manager. However it works entirely differently from
-    #! the URL and cookie session managers.
     H{ } clone callback-responder boa ;
 
 TUPLE: callback cont quot expires alarm responder ;
@@ -44,7 +42,7 @@ TUPLE: callback cont quot expires alarm responder ;
 : register-callback ( cont quot expires? -- id )
     <callback> callback-responder get callbacks>> set-at-unique ;
 
-: forward-to-url ( url query -- * )
+: forward-to-url ( url -- * )
     #! When executed inside a 'show' call, this will force a
     #! HTTP 302 to occur to instruct the browser to forward to
     #! the request URL.
@@ -56,7 +54,8 @@ TUPLE: callback cont quot expires alarm responder ;
     #! When executed inside a 'show' call, this will force a
     #! HTTP 302 to occur to instruct the browser to forward to
     #! the request URL.
-    f swap cont-id associate forward-to-url ;
+    <url>
+        swap cont-id set-query-param forward-to-url ;
 
 : restore-request ( pair -- )
     first3 exit-continuation set request set call ;
@@ -94,7 +93,7 @@ SYMBOL: current-show
     call exit-with ; inline
 
 : resuming-callback ( responder request -- id )
-    cont-id query-param swap callbacks>> at ;
+    url>> cont-id query-param swap callbacks>> at ;
 
 M: callback-responder call-responder* ( path responder -- response )
     '[