Web framework refactoring work in progress

extra/furnace/actions/actions-tests.factor

@@ -1,7 +1,7 @@
-USING: kernel http.server.actions validators
+USING: kernel furnace.actions validators
 tools.test math math.parser multiline namespaces http
 io.streams.string http.server sequences splitting accessors ;
-IN: http.server.actions.tests
+IN: furnace.actions.tests
 
 <action>
     [ "a" param "b" param [ string>number ] bi@ + ] >>display
@@ -16,9 +16,8 @@ blah
 ;
 
 [ 25 ] [
-    init-request
     action-request-test-1 lf>crlf
     [ read-request ] with-string-reader
-    request set
+    init-request
     { } "action-1" get call-responder
 ] unit-test

extra/furnace/actions/actions.factor

@@ -2,8 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors sequences kernel assocs combinators http.server
 validators http hashtables namespaces fry continuations locals
-boxes xml.entities html.elements html.components io arrays math ;
+boxes xml.entities html.elements html.components
-IN: http.server.actions
+html.templates.chloe io arrays math ;
+IN: furnace.actions
 
 SYMBOL: params
 
@@ -17,6 +18,8 @@ SYMBOL: rest-param
         </ul>
     ] if ;
 
+CHLOE: validation-messages drop render-validation-messages ;
+
 TUPLE: action rest-param init display validate submit ;
 
 : new-action ( class -- action )
@@ -75,7 +78,7 @@ M: action call-responder* ( path action -- response )
     validation-failed? [ validation-failed ] when ;
 
 : validate-params ( validators -- )
-    params get swap validate-values from-assoc
+    params get swap validate-values from-object
     check-validation ;
 
 : validate-integer-id ( -- )
@@ -83,12 +86,15 @@ M: action call-responder* ( path action -- response )
 
 TUPLE: page-action < action template ;
 
+: <chloe-content> ( path -- response )
+    resolve-template-path <chloe> "text/html" <content> ;
+
 : <page-action> ( -- page )
     page-action new-action
-        dup '[ , template>> <html-content> ] >>display ;
+        dup '[ , template>> <chloe-content> ] >>display ;
 
 TUPLE: feed-action < action feed ;
 
 : <feed-action> ( -- feed )
-    feed-action new
+    feed-action new-action
         dup '[ , feed>> call <feed-content> ] >>display ;

extra/furnace/auth/auth.factor

@@ -2,9 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs namespaces kernel sequences sets
 http.server
-http.server.sessions
+furnace.sessions
-http.server.auth.providers ;
+furnace.auth.providers ;
-IN: http.server.auth
+IN: furnace.auth
 
 SYMBOL: logged-in-user
 

extra/furnace/auth/basic/basic.factor

@@ -2,9 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors quotations assocs kernel splitting
 base64 html.elements io combinators http.server
-http.server.auth.providers http.server.auth.login
+furnace.auth.providers furnace.auth.login
 http sequences ;
-IN: http.server.auth.basic
+IN: furnace.auth.basic
 
 TUPLE: basic-auth < filter-responder realm provider ;
 

extra/furnace/auth/login/login-tests.factor

@@ -1,5 +1,5 @@
-IN: http.server.auth.login.tests
+IN: furnace.auth.login.tests
-USING: tools.test http.server.auth.login ;
+USING: tools.test furnace.auth.login ;
 
 \ <login> must-infer
 \ allow-registration must-infer

extra/furnace/auth/login/login.factor

@@ -15,19 +15,18 @@ checksums.sha2
 validators
 html.components
 html.elements
-html.templates
+urls
-html.templates.chloe
 http
 http.server
-http.server.auth
+furnace.auth
-http.server.auth.providers
+furnace.auth.providers
-http.server.auth.providers.db
+furnace.auth.providers.db
-http.server.actions
+furnace.actions
-http.server.flows
+furnace.flows
-http.server.sessions
+furnace.sessions
-http.server.boilerplate ;
+furnace.boilerplate ;
 QUALIFIED: smtp
-IN: http.server.auth.login
+IN: furnace.auth.login
 
 TUPLE: login < dispatcher users checksum ;
 
@@ -59,10 +58,6 @@ M: user-saver dispose
 : save-user-after ( user -- )
     <user-saver> &dispose drop ;
 
-: login-template ( name -- template )
-    "resource:extra/http/server/auth/login/" swap ".xml"
-    3append <chloe> ;
-
 ! ! ! Login
 : successful-login ( user -- response )
     username>> set-uid "$login" end-flow ;
@@ -72,8 +67,8 @@ M: user-saver dispose
     validation-failed ;
 
 : <login-action> ( -- action )
-    <action>
+    <page-action>
-        [ "login" login-template <html-content> ] >>display
+        "$login/login" >>template
 
         [
             {
@@ -102,7 +97,7 @@ M: user-saver dispose
 
 : <register-action> ( -- action )
     <page-action>
-        "register" login-template >>template
+        "$login/register" >>template
 
         [
             {
@@ -134,7 +129,7 @@ M: user-saver dispose
 ! ! ! Editing user profile
 
 : <edit-profile-action> ( -- action )
-    <action>
+    <page-action>
         [
             logged-in-user get
             [ username>> "username" set-value ]
@@ -143,7 +138,7 @@ M: user-saver dispose
             tri
         ] >>init
 
-        [ "edit-profile" login-template <html-content> ] >>display
+        "$login/edit-profile" >>template
 
         [
             uid "username" set-value
@@ -186,10 +181,10 @@ M: user-saver dispose
 SYMBOL: lost-password-from
 
 : current-host ( -- string )
-    request get host>> host-name or ;
+    request get url>> host>> host-name or ;
 
 : new-password-url ( user -- url )
-    "new-password"
+    "recover-3"
     swap [
         [ username>> "username" set ]
         [ ticket>> "ticket" set ]
@@ -223,8 +218,8 @@ SYMBOL: lost-password-from
     "E-mail send thread" spawn drop ;
 
 : <recover-action-1> ( -- action )
-    <action>
+    <page-action>
-        [ "recover-1" login-template <html-content> ] >>display
+        "$login/recover-1" >>template
 
         [
             {
@@ -240,11 +235,15 @@ SYMBOL: lost-password-from
                 send-password-email
             ] when*
 
-            "recover-2" login-template <html-content>
+            URL" $login/recover-2" <redirect>
         ] >>submit ;
 
+: <recover-action-2> ( -- action )
+    <page-action>
+        "$login/recover-2" >>template ;
+
 : <recover-action-3> ( -- action )
-    <action>
+    <page-action>
         [
             {
                 { "username" [ v-username ] }
@@ -252,7 +251,7 @@ SYMBOL: lost-password-from
             } validate-params
         ] >>init
 
-        [ "recover-3" login-template <html-content> ] >>display
+        "$login/recover-3" >>template
 
         [
             {
@@ -272,12 +271,16 @@ SYMBOL: lost-password-from
                 "new-password" value >>encoded-password
                 users update-user
 
-                "recover-4" login-template <html-content>
+                URL" $login/recover-4" <redirect>
             ] [
                 <400>
             ] if*
         ] >>submit ;
 
+: <recover-action-4> ( -- action )
+    <page-action>
+        "$login/recover-4" >>template ;
+
 ! ! ! Logout
 : <logout-action> ( -- action )
     <action>
@@ -294,7 +297,7 @@ C: <protected> protected
 
 : show-login-page ( -- response )
     begin-flow
-    "$login/login" f <standard-redirect> ;
+    URL" $login/login" <redirect> ;
 
 : check-capabilities ( responder user -- ? )
     [ capabilities>> ] bi@ subset? ;
@@ -317,7 +320,7 @@ M: login call-responder* ( path responder -- response )
 
 : <login-boilerplate> ( responder -- responder' )
     <boilerplate>
-        "boilerplate" login-template >>template ;
+        "$login/boilerplate" >>template ;
 
 : <login> ( responder -- auth )
     login new-dispatcher
@@ -340,8 +343,12 @@ M: login call-responder* ( path responder -- response )
 : allow-password-recovery ( login -- login )
     <recover-action-1> <login-boilerplate>
         "recover-password" add-responder
+    <recover-action-2> <login-boilerplate>
+        "recover-2" add-responder
     <recover-action-3> <login-boilerplate>
-        "new-password" add-responder ;
+        "recover-3" add-responder
+    <recover-action-4> <login-boilerplate>
+        "recover-4" add-responder ;
 
 : allow-edit-profile? ( -- ? )
     login get responders>> "edit-profile" swap key? ;

extra/furnace/auth/providers/assoc/assoc-tests.factor

@@ -1,6 +1,6 @@
-IN: http.server.auth.providers.assoc.tests
+IN: furnace.auth.providers.assoc.tests
-USING: http.server.actions http.server.auth.providers 
+USING: furnace.actions furnace.auth.providers 
-http.server.auth.providers.assoc http.server.auth.login
+furnace.auth.providers.assoc furnace.auth.login
 tools.test namespaces accessors kernel ;
 
 <action> <login>

extra/furnace/auth/providers/assoc/assoc.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: http.server.auth.providers.assoc
+IN: furnace.auth.providers.assoc
-USING: accessors assocs kernel
+USING: accessors assocs kernel furnace.auth.providers ;
-http.server.auth.providers ;
 
 TUPLE: users-in-memory assoc ;
 

extra/furnace/auth/providers/db/db-tests.factor

@@ -1,8 +1,8 @@
-IN: http.server.auth.providers.db.tests
+IN: furnace.auth.providers.db.tests
-USING: http.server.actions
+USING: furnace.actions
-http.server.auth.login
+furnace.auth.login
-http.server.auth.providers
+furnace.auth.providers
-http.server.auth.providers.db tools.test
+furnace.auth.providers.db tools.test
 namespaces db db.sqlite db.tuples continuations
 io.files accessors kernel ;
 

extra/furnace/auth/providers/db/db.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: db db.tuples db.types accessors
-http.server.auth.providers kernel continuations
+furnace.auth.providers kernel continuations
 classes.singleton ;
-IN: http.server.auth.providers.db
+IN: furnace.auth.providers.db
 
 user "USERS"
 {

extra/furnace/auth/providers/null/null.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: http.server.auth.providers kernel ;
+USING: furnace.auth.providers kernel ;
-IN: http.server.auth.providers.null
+IN: furnace.auth.providers.null
 
 TUPLE: no-users ;
 

extra/furnace/auth/providers/providers.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors random math.parser locals
 sequences math ;
-IN: http.server.auth.providers
+IN: furnace.auth.providers
 
 TUPLE: user
 username realname

extra/furnace/boilerplate/boilerplate.factor

@@ -1,8 +1,8 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces http.server html.templates
-locals ;
+html.templates.chloe locals ;
-IN: http.server.boilerplate
+IN: furnace.boilerplate
 
 TUPLE: boilerplate < filter-responder template ;
 
@@ -12,6 +12,10 @@ M:: boilerplate call-responder* ( path responder -- )
     path responder call-next-method
     dup content-type>> "text/html" = [
         clone [| body |
-            [ body responder template>> with-boilerplate ]
+            [
+                body
+                responder template>> resolve-template-path <chloe>
+                with-boilerplate
+            ]
         ] change-body
     ] when ;

extra/furnace/callbacks/callbacks-tests.factor

@@ -1,5 +1,5 @@
-IN: http.server.callbacks
+IN: furnace.callbacks
-USING: http.server.actions http.server.callbacks accessors
+USING: furnace.actions furnace.callbacks accessors
 http.server http tools.test namespaces io fry sequences
 splitting kernel hashtables continuations ;
 
@@ -24,7 +24,7 @@ splitting kernel hashtables continuations ;
     <action> [
         [
             "hello" print
-            '[ , write ] <html-content>
+            "text/html" <content>
         ] show-page
         "byebye" print
         [ 123 ] show-final

extra/furnace/callbacks/callbacks.factor

@@ -4,7 +4,7 @@
 USING: http http.server io kernel math namespaces
 continuations calendar sequences assocs hashtables
 accessors arrays alarms quotations combinators fry assocs.lib ;
-IN: http.server.callbacks
+IN: furnace.callbacks
 
 SYMBOL: responder
 

extra/furnace/db/db-tests.factor

@@ -0,0 +1,4 @@
+IN: furnace.db.tests
+USING: tools.test furnace.db ;
+
+\ <db-persistence> must-infer

extra/furnace/db/db.factor

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

extra/furnace/flows/flows.factor

@@ -1,9 +1,10 @@
 ! 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
+assocs assocs.lib hashtables math.parser urls combinators
-html.elements http http.server http.server.sessions ;
+html.elements http http.server furnace.sessions
-IN: http.server.flows
+html.templates.chloe.syntax ;
+IN: furnace.flows
 
 TUPLE: flows < filter-responder ;
 
@@ -11,24 +12,28 @@ C: <flows> flows
 
 : begin-flow* ( -- id )
     request get
-    [ path>> ] [ request-params ] [ method>> ] tri 3array
+    [ url>> ] [ post-data>> ] [ method>> ] tri 3array
     flows sget set-at-unique
     session-changed ;
 
-: end-flow-post ( path params -- response )
+: end-flow-post ( url post-data -- response )
     request [
         clone
             "POST" >>method
             swap >>post-data
-            swap >>path
+            swap >>url
     ] change
-    request get path>> split-path
+    request get url>> path>> split-path
     flows get responder>> call-responder ;
 
-: end-flow* ( default id -- response )
+: end-flow* ( url id -- response )
-    flows sget at
+    flows sget at [
-    [ first3 "POST" = [ end-flow-post ] [ <standard-redirect> ] if ]
+        first3 {
-    [ f <standard-redirect> ] ?if ;
+            { "GET" [ drop <redirect> ] }
+            { "HEAD" [ drop <redirect> ] }
+            { "POST" [ end-flow-post ] }
+        } case
+    ] [ <redirect> ] ?if ;
 
 SYMBOL: flow-id
 
@@ -40,10 +45,30 @@ SYMBOL: flow-id
 : end-flow ( default -- response )
     flow-id get end-flow* ;
 
-: add-flow-id ( query -- query' )
+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* ;
 
-: flow-form-field ( -- )
+M: flows hidden-form-field ( responder -- )
+    drop
     flow-id get [
         <input
             "hidden" =type
@@ -51,14 +76,3 @@ SYMBOL: flow-id
             =value
         input/>
     ] when* ;
-
-M: flows call-responder*
-    dup flows set
-    [ add-flow-id ] add-link-hook
-    [ flow-form-field ] add-form-hook
-    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 ;

extra/furnace/furnace.factor

@@ -0,0 +1,136 @@
+! Copyright (C) 2003, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: furnace
+
+GENERIC: hidden-form-field ( responder -- )
+
+M: object hidden-form-field drop ;
+
+: request-params ( request -- assoc )
+    dup method>> {
+        { "GET" [ url>> query>> ] }
+        { "HEAD" [ url>> query>> ] }
+        { "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 ;
+
+: with-exit-continuation ( quot -- )
+    '[ exit-continuation set @ ] callcc1 exit-continuation off ;
+
+! Chloe tags
+: parse-query-attr ( string -- assoc )
+    dup empty?
+    [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
+
+CHLOE: atom
+    [ "title" required-attr ]
+    [ "href" required-attr ]
+    [ "query" optional-attr parse-query-attr ] tri
+    <url>
+        swap >>query
+        swap >>path
+    adjust-url
+    add-atom-feed ;
+
+CHLOE: write-atom drop write-atom-feeds ;
+
+GENERIC: link-attr ( tag responder -- )
+
+M: object link-attr 2drop ;
+
+: link-attrs ( tag -- )
+    '[ , _ link-attr ] each-responder ;
+
+: a-start-tag ( tag -- )
+    [
+        <a
+            dup link-attrs
+            dup "value" optional-attr [ value f ] [
+                [ "href" required-attr ]
+                [ "query" optional-attr parse-query-attr ]
+                bi
+            ] ?if
+            <url>
+                swap >>query
+                swap >>path
+            adjust-url =href
+        a>
+    ] with-scope ;
+
+CHLOE: a
+    [ a-start-tag ]
+    [ process-tag-children ]
+    [ drop </a> ]
+    tri ;
+
+: form-start-tag ( tag -- )
+    [
+        [
+            <form
+            "POST" =method
+            [ link-attrs ]
+            [ "action" required-attr resolve-base-path =action ]
+            [ tag-attrs non-chloe-attrs-only print-attrs ]
+            tri
+            form>
+        ] [
+            [ hidden-form-field ] each-responder
+            "for" optional-attr [ hidden render ] when*
+        ] bi
+    ] with-scope ;
+
+CHLOE: form
+    [ form-start-tag ]
+    [ process-tag-children ]
+    [ 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>
+</t:form>
+;
+
+: add-tag-attrs ( attrs tag -- )
+    tag-attrs swap update ;
+
+CHLOE: button
+    button-tag-markup string>xml delegate
+    {
+        [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
+        [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
+        [ [ 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 -- ? )
+    t swap
+    {
+        [ "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/sessions/sessions-tests.factor

@@ -1,8 +1,8 @@
-IN: http.server.sessions.tests
+IN: furnace.sessions.tests
-USING: tools.test http http.server.sessions
+USING: tools.test http furnace.sessions
-http.server.actions http.server math namespaces kernel accessors
+furnace.actions http.server math namespaces kernel accessors
 prettyprint io.streams.string io.files splitting destructors
-sequences db db.sqlite continuations ;
+sequences db db.sqlite continuations urls ;
 
 : with-session
     [
@@ -18,15 +18,16 @@ M: foo init-session* drop 0 "x" sset ;
 M: foo call-responder*
     2drop
     "x" [ 1+ ] schange
-    [ "x" sget pprint ] <html-content> ;
+    "x" sget number>string "text/html" <content> ;
 
 : url-responder-mock-test
     [
         <request>
             "GET" >>method
-            "id" get session-id-key set-query-param
+            dup url>>
-            "/" >>path
+                "id" get session-id-key set-query-param
-        request set
+                "/" >>path drop
+        init-request
         { } sessions get call-responder
         [ write-response-body drop ] with-string-writer
     ] with-destructors ;
@@ -36,21 +37,21 @@ M: foo call-responder*
         <request>
             "GET" >>method
             "cookies" get >>cookies
-            "/" >>path
+            dup url>> "/" >>path drop
-        request set
+        init-request
         { } sessions get call-responder
         [ write-response-body drop ] with-string-writer
     ] with-destructors ;
 
 : <exiting-action>
     <action>
-        [ [ ] <text-content> exit-with ] >>display ;
+        [ [ ] "text/plain" <content> exit-with ] >>display ;
 
 [ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors
 
 "auth-test.db" temp-file sqlite-db [
 
-    init-request
+    <request> init-request
     init-sessions-table
 
     [ ] [
@@ -112,8 +113,8 @@ M: foo call-responder*
 
     [
         <request>
-        "GET" >>method
+            "GET" >>method
-        "/" >>path
+            dup url>> "/" >>path drop
         request set
         { "etc" } sessions get call-responder response set
         [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
@@ -131,8 +132,9 @@ M: foo call-responder*
         [ ] [
             <request>
                 "GET" >>method
-                "id" get session-id-key set-query-param
+                dup url>>
-                "/" >>path
+                    "id" get session-id-key set-query-param
+                    "/" >>path drop
             request set
 
             [

extra/furnace/sessions/sessions.factor

@@ -4,8 +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 ;
+http http.server html.elements html.templates.chloe ;
-IN: http.server.sessions
+IN: furnace.sessions
 
 TUPLE: session id expires uid namespace changed? ;
 
@@ -136,7 +136,8 @@ M: session-saver dispose
 : put-session-cookie ( response -- response' )
     session get id>> number>string <session-cookie> put-cookie ;
 
-: session-form-field ( -- )
+M: sessions hidden-form-field ( responder -- )
+    drop
     <input
         "hidden" =type
         session-id-key =name
@@ -144,10 +145,17 @@ M: session-saver dispose
     input/> ;
 
 M: sessions call-responder* ( path responder -- response )
-    [ session-form-field ] add-form-hook
     sessions set
     request-session [ begin-session ] unless*
     existing-session put-session-cookie ;
 
 : 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/components/components-tests.factor

@@ -11,7 +11,7 @@ html.components namespaces ;
 
 TUPLE: color red green blue ;
 
-[ ] [ 1 2 3 color boa from-tuple ] unit-test
+[ ] [ 1 2 3 color boa from-object ] unit-test
 
 [ 1 ] [ "red" value ] unit-test
 
@@ -107,7 +107,7 @@ TUPLE: color red green blue ;
 
 [ ] [ t "delivery" set-value ] unit-test
 
-[ "<input type='checkbox' name='delivery' selected='true'>Delivery</input>" ] [
+[ "<input type='checkbox' name='delivery' checked='true'>Delivery</input>" ] [
     [
         "delivery"
         <checkbox>

extra/html/components/components.factor

@@ -5,7 +5,7 @@ classes.tuple words arrays sequences sequences.lib splitting
 mirrors hashtables combinators continuations math strings
 fry locals calendar calendar.format xml.entities validators
 html.elements html.streams xmode.code2html farkup inspector
-lcs.diff2html ;
+lcs.diff2html urls ;
 IN: html.components
 
 SYMBOL: values
@@ -19,9 +19,9 @@ SYMBOL: values
 : prepare-value ( name object -- value name object )
     [ [ value ] keep ] dip ; inline
 
-: from-assoc ( assoc -- ) values get swap update ;
+: from-object ( object -- )
-
+    dup assoc? [ <mirror> ] unless
-: from-tuple ( tuple -- ) <mirror> from-assoc ;
+    values get swap update ;
 
 : deposit-values ( destination names -- )
     [ dup value ] H{ } map>assoc update ;
@@ -32,24 +32,19 @@ SYMBOL: values
 : with-each-index ( seq quot -- )
     '[
         [
-            blank-values 1+ "index" set-value @
+            values [ clone ] change
+            1+ "index" set-value @
         ] with-scope
     ] each-index ; inline
 
 : with-each-value ( seq quot -- )
     '[ "value" set-value @ ] with-each-index ; inline
 
-: with-each-assoc ( seq quot -- )
+: with-each-object ( seq quot -- )
-    '[ from-assoc @ ] with-each-index ; inline
+    '[ from-object @ ] with-each-index ; inline
 
-: with-each-tuple ( seq quot -- )
+: with-values ( object quot -- )
-    '[ from-tuple @ ] with-each-index ; inline
+    '[ blank-values , from-object @ ] with-scope ; inline
-
-: with-assoc-values ( assoc quot -- )
-    '[ blank-values , from-assoc @ ] with-scope ; inline
-
-: with-tuple-values ( assoc quot -- )
-    '[ blank-values , from-tuple @ ] with-scope ; inline
 
 : nest-values ( name quot -- )
     swap [
@@ -58,22 +53,6 @@ SYMBOL: values
         ] with-scope
     ] dip set-value ; inline
 
-: nest-tuple ( name quot -- )
-    swap [
-        [
-            H{ } clone [ <mirror> values set call ] keep
-        ] with-scope
-    ] dip set-value ; inline
-
-: object>string ( object -- string )
-    {
-        { [ dup real? ] [ number>string ] }
-        { [ dup timestamp? ] [ timestamp>string ] }
-        { [ dup string? ] [ ] }
-        { [ dup word? ] [ word-name ] }
-        { [ dup not ] [ drop "" ] }
-    } cond ;
-
 GENERIC: render* ( value name render -- )
 
 : render ( name renderer -- )
@@ -174,7 +153,7 @@ M: checkbox render*
     <input
         "checkbox" =type
         swap =name
-        swap [ "true" =selected ] when
+        swap [ "true" =checked ] when
     input>
         label>> escape-string write
     </input> ;

extra/html/elements/elements.factor

@@ -4,7 +4,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: io kernel namespaces prettyprint quotations
-sequences strings words xml.entities compiler.units effects ;
+sequences strings words xml.entities compiler.units effects
+urls math math.parser combinators calendar calendar.format ;
 
 IN: html.elements
 
@@ -126,11 +127,22 @@ SYMBOL: html
     dup def-for-html-word-<foo
     def-for-html-word-foo/> ;
 
+: object>string ( object -- string )
+    #! Should this be generic and in the core?
+    {
+        { [ dup real? ] [ number>string ] }
+        { [ dup timestamp? ] [ timestamp>string ] }
+        { [ dup url? ] [ url>string ] }
+        { [ dup string? ] [ ] }
+        { [ dup word? ] [ word-name ] }
+        { [ dup not ] [ drop "" ] }
+    } cond ;
+
 : write-attr ( value name -- )
     " " write-html
     write-html
     "='" write-html
-    escape-quoted-string write-html
+    object>string escape-quoted-string write-html
     "'" write-html ;
 
 : attribute-effect T{ effect f { "string" } 0 } ;
@@ -162,7 +174,7 @@ SYMBOL: html
     "id" "onclick" "style" "valign" "accesskey"
     "src" "language" "colspan" "onchange" "rel"
     "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
-    "media" "title" "multiple"
+    "media" "title" "multiple" "checked"
 ] [ define-attribute-word ] each
 
 >>

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

@@ -27,8 +27,7 @@ IN: html.templates.chloe.tests
 
 : test-template ( name -- template )
     "resource:extra/html/templates/chloe/test/"
-    swap
+    prepend <chloe> ;
-    ".xml" 3append <chloe> ;
 
 [ "Hello world" ] [
     [
@@ -156,6 +155,14 @@ TUPLE: person first-name last-name ;
 
 [ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
     [
-        "test11" test-template call-template
+        "test10" test-template call-template
     ] run-template [ blank? not ] filter
 ] unit-test
+
+[ ] [ 1 "id" set-value ] unit-test
+
+[ "<a name=\"1\">Hello</a>" ] [
+    [
+        "test11" test-template call-template
+    ] run-template
+] unit-test

extra/html/templates/chloe/chloe.factor

@@ -3,16 +3,12 @@
 USING: accessors kernel sequences combinators kernel namespaces
 classes.tuple assocs splitting words arrays memoize
 io io.files io.encodings.utf8 io.streams.string
-unicode.case tuple-syntax mirrors fry math
+unicode.case tuple-syntax mirrors fry math urls
 multiline xml xml.data xml.writer xml.utilities
 html.elements
 html.components
 html.templates
-http.server
+html.templates.chloe.syntax ;
-http.server.auth
-http.server.flows
-http.server.actions
-http.server.sessions ;
 IN: html.templates.chloe
 
 ! Chloe is Ed's favorite web designer
@@ -23,8 +19,6 @@ C: <chloe> chloe
 
 DEFER: process-template
 
-: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
-
 : chloe-attrs-only ( assoc -- assoc' )
     [ drop name-url chloe-ns = ] assoc-filter ;
 
@@ -38,35 +32,22 @@ DEFER: process-template
         [ t ]
     } cond nip ;
 
-SYMBOL: tags
-
-MEMO: chloe-name ( string -- name )
-    name new
-        swap >>tag
-        chloe-ns >>url ;
-
-: required-attr ( tag name -- value )
-    dup chloe-name rot at*
-    [ nip ] [ drop " attribute is required" append throw ] if ;
-
-: optional-attr ( tag name -- value )
-    chloe-name swap at ;
-
 : process-tag-children ( tag -- )
     [ process-template ] each ;
 
+CHLOE: chloe process-tag-children ;
+
 : children>string ( tag -- string )
     [ process-tag-children ] with-string-writer ;
 
-: title-tag ( tag -- )
+CHLOE: title children>string set-title ;
-    children>string set-title ;
 
-: write-title-tag ( tag -- )
+CHLOE: write-title
     drop
     "head" tags get member? "title" tags get member? not and
     [ <title> write-title </title> ] [ write-title ] if ;
 
-: style-tag ( tag -- )
+CHLOE: style
     dup "include" optional-attr dup [
         swap children>string empty? [
             "style tag cannot have both an include attribute and a body" throw
@@ -76,146 +57,12 @@ MEMO: chloe-name ( string -- name )
         drop children>string
     ] if add-style ;
 
-: write-style-tag ( tag -- )
+CHLOE: write-style
     drop <style> write-style </style> ;
 
-: atom-tag ( tag -- )
+CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ;
-    [ "title" required-attr ]
-    [ "href" required-attr ]
-    bi set-atom-feed ;
 
-: write-atom-tag ( tag -- )
+CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
-    drop
-    "head" tags get member? [
-        write-atom-feed
-    ] [
-        atom-feed get value>> second write
-    ] if ;
-
-: parse-query-attr ( string -- assoc )
-    dup empty?
-    [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
-
-: flow-attr ( tag -- )
-    "flow" optional-attr {
-        { "none" [ flow-id off ] }
-        { "begin" [ begin-flow ] }
-        { "current" [ ] }
-        { f [ ] }
-    } case ;
-
-: session-attr ( tag -- )
-    "session" optional-attr {
-        { "none" [ session off flow-id off ] }
-        { "current" [ ] }
-        { f [ ] }
-    } case ;
-
-: a-start-tag ( tag -- )
-    [
-        <a
-        dup flow-attr
-        dup session-attr
-        dup "value" optional-attr [ value f ] [
-            [ "href" required-attr ]
-            [ "query" optional-attr parse-query-attr ]
-            bi
-        ] ?if link>string =href
-        a>
-    ] with-scope ;
-
-: a-tag ( tag -- )
-    [ a-start-tag ]
-    [ process-tag-children ]
-    [ drop </a> ]
-    tri ;
-
-: form-start-tag ( tag -- )
-    [
-        [
-            <form
-            "POST" =method
-            {
-                [ flow-attr ]
-                [ session-attr ]
-                [ "action" required-attr resolve-base-path =action ]
-                [ tag-attrs non-chloe-attrs-only print-attrs ]
-            } cleave
-            form>
-        ] [
-            hidden-form-field
-            "for" optional-attr [ hidden render ] when*
-        ] bi
-    ] with-scope ;
-
-: form-tag ( tag -- )
-    [ form-start-tag ]
-    [ process-tag-children ]
-    [ 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>
-</t:form>
-;
-
-: add-tag-attrs ( attrs tag -- )
-    tag-attrs swap update ;
-
-: button-tag ( tag -- )
-    button-tag-markup string>xml delegate
-    {
-        [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
-        [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
-        [ [ 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 -- ? )
-    t swap
-    {
-        [ "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 ;
-
-: if-tag ( tag -- )
-    dup if-satisfied? [ process-tag-children ] [ drop ] if ;
-
-: even-tag ( tag -- )
-    "index" value even? [ process-tag-children ] [ drop ] if ;
-
-: odd-tag ( tag -- )
-    "index" value odd? [ process-tag-children ] [ drop ] if ;
-
-: (each-tag) ( tag quot -- )
-    [
-        [ "values" required-attr value ] keep
-        '[ , process-tag-children ]
-    ] dip call ; inline
-
-: each-tag ( tag -- )
-    [ with-each-value ] (each-tag) ;
-
-: each-tuple-tag ( tag -- )
-    [ with-each-tuple ] (each-tag) ;
-
-: each-assoc-tag ( tag -- )
-    [ with-each-assoc ] (each-tag) ;
 
 : (bind-tag) ( tag quot -- )
     [
@@ -223,83 +70,36 @@ STRING: button-tag-markup
         '[ , process-tag-children ]
     ] dip call ; inline
 
-: bind-tuple-tag ( tag -- )
+CHLOE: each [ with-each-value ] (bind-tag) ;
-    [ with-tuple-values ] (bind-tag) ;
 
-: bind-assoc-tag ( tag -- )
+CHLOE: bind-each [ with-each-object ] (bind-tag) ;
-    [ with-assoc-values ] (bind-tag) ;
+
+CHLOE: bind [ with-values ] (bind-tag) ;
 
 : error-message-tag ( tag -- )
     children>string render-error ;
 
-: validation-messages-tag ( tag -- )
+CHLOE: comment drop ;
-    drop render-validation-messages ;
 
-: singleton-component-tag ( tag class -- )
+CHLOE: call-next-template drop call-next-template ;
-    [ "name" required-attr ] dip render ;
 
-: attrs>slots ( tag tuple -- )
+CHLOE-SINGLETON: label
-    [ attrs>> ] [ <mirror> ] bi*
+CHLOE-SINGLETON: link
-    '[
+CHLOE-SINGLETON: farkup
-        swap tag>> dup "name" =
+CHLOE-SINGLETON: inspector
-        [ 2drop ] [ , set-at ] if
+CHLOE-SINGLETON: comparison
-    ] assoc-each ;
+CHLOE-SINGLETON: html
+CHLOE-SINGLETON: hidden
 
-: tuple-component-tag ( tag class -- )
+CHLOE-TUPLE: field
-    [ drop "name" required-attr ]
+CHLOE-TUPLE: password
-    [ new [ attrs>slots ] keep ]
+CHLOE-TUPLE: choice
-    2bi render ;
+CHLOE-TUPLE: checkbox
+CHLOE-TUPLE: code
 
 : process-chloe-tag ( tag -- )
-    dup name-tag {
+    dup name-tag tags get at
-        { "chloe" [ process-tag-children ] }
+    [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
-
-        ! HTML head
-        { "title" [ title-tag ] }
-        { "write-title" [ write-title-tag ] }
-        { "style" [ style-tag ] }
-        { "write-style" [ write-style-tag ] }
-        { "atom" [ atom-tag ] }
-        { "write-atom" [ write-atom-tag ] }
-
-        ! HTML elements
-        { "a" [ a-tag ] }
-        { "button" [ button-tag ] }
-
-        ! Components
-        { "label" [ label singleton-component-tag ] }
-        { "link" [ link singleton-component-tag ] }
-        { "code" [ code tuple-component-tag ] }
-        { "farkup" [ farkup singleton-component-tag ] }
-        { "inspector" [ inspector singleton-component-tag ] }
-        { "comparison" [ comparison singleton-component-tag ] }
-        { "html" [ html singleton-component-tag ] }
-
-        ! Forms
-        { "form" [ form-tag ] }
-        { "error-message" [ error-message-tag ] }
-        { "validation-messages" [ validation-messages-tag ] }
-        { "hidden" [ hidden singleton-component-tag ] }
-        { "field" [ field tuple-component-tag ] }
-        { "password" [ password tuple-component-tag ] }
-        { "textarea" [ textarea tuple-component-tag ] }
-        { "choice" [ choice tuple-component-tag ] }
-        { "checkbox" [ checkbox tuple-component-tag ] }
-
-        ! Control flow
-        { "if" [ if-tag ] }
-        { "even" [ even-tag ] }
-        { "odd" [ odd-tag ] }
-        { "each" [ each-tag ] }
-        { "each-assoc" [ each-assoc-tag ] }
-        { "each-tuple" [ each-tuple-tag ] }
-        { "bind-assoc" [ bind-assoc-tag ] }
-        { "bind-tuple" [ bind-tuple-tag ] }
-        { "comment" [ drop ] }
-        { "call-next-template" [ drop call-next-template ] }
-
-        [ "Unknown chloe tag: " prepend throw ]
-    } case ;
 
 : process-tag ( tag -- )
     {
@@ -310,7 +110,15 @@ STRING: button-tag-markup
         [ drop tags get pop* ]
     } cleave ;
 
+: expand-attrs ( tag -- tag )
+    dup [ tag? ] is? [
+        clone [
+            [ "@" ?head [ value object>string ] when ] assoc-map
+        ] change-attrs
+    ] when ;
+
 : process-template ( xml -- )
+    expand-attrs
     {
         { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
         { [ dup [ tag? ] is? ] [ process-tag ] }
@@ -334,6 +142,6 @@ STRING: button-tag-markup
     ] with-scope ;
 
 M: chloe call-template*
-    path>> utf8 <file-reader> read-xml process-chloe ;
+    path>> ".xml" append utf8 <file-reader> read-xml process-chloe ;
 
 INSTANCE: chloe template

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

@@ -0,0 +1,58 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: html.templates.chloe.syntax
+USING: accessors kernel sequences combinators kernel namespaces
+classes.tuple assocs splitting words arrays memoize parser
+io io.files io.encodings.utf8 io.streams.string
+unicode.case tuple-syntax mirrors fry math urls
+multiline xml xml.data xml.writer xml.utilities
+html.elements
+html.components
+html.templates ;
+
+SYMBOL: tags
+
+tags global [ H{ } clone or ] change-at
+
+: define-chloe-tag ( name quot -- ) tags get set-at ;
+
+: CHLOE:
+    scan parse-definition swap define-chloe-tag ;
+    parsing
+
+: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
+
+MEMO: chloe-name ( string -- name )
+    name new
+        swap >>tag
+        chloe-ns >>url ;
+
+: required-attr ( tag name -- value )
+    dup chloe-name rot at*
+    [ nip ] [ drop " attribute is required" append throw ] if ;
+
+: optional-attr ( tag name -- value )
+    chloe-name swap at ;
+
+: singleton-component-tag ( tag class -- )
+    [ "name" required-attr ] dip render ;
+
+: CHLOE-SINGLETON:
+    scan dup '[ , singleton-component-tag ] define-chloe-tag ;
+    parsing
+
+: attrs>slots ( tag tuple -- )
+    [ attrs>> ] [ <mirror> ] bi*
+    '[
+        swap tag>> dup "name" =
+        [ 2drop ] [ , set-at ] if
+    ] assoc-each ;
+
+: tuple-component-tag ( tag class -- )
+    [ drop "name" required-attr ]
+    [ new [ attrs>slots ] keep ]
+    2bi render ;
+
+: CHLOE-TUPLE:
+    scan dup '[ , tuple-component-tag ] define-chloe-tag ;
+    parsing

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

@@ -3,12 +3,12 @@
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
 	<table>
-		<t:each-tuple t:values="people">
+		<t:bind-each t:name="people">
 			<tr>
 				<td><t:label t:name="first-name"/></td>
 				<td><t:label t:name="last-name"/></td>
 			</tr>
-		</t:each-tuple>
+		</t:bind-each>
 	</table>
 
 </t:chloe>

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

@@ -1,14 +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>
-
-	<table>
-		<t:each-assoc t:values="people">
-			<tr>
-				<td><t:label t:name="first-name"/></td>
-				<td><t:label t:name="last-name"/></td>
-			</tr>
-		</t:each-assoc>
-	</table>
-
-</t:chloe>

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

@@ -3,7 +3,7 @@
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
 	<ul>
-		<t:each t:values="numbers">
+		<t:each t:name="numbers">
 			<li><t:label t:name="value"/></li>
 		</t:each>
 	</ul>

extra/html/templates/templates.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel fry io io.encodings.utf8 io.files
 debugger prettyprint continuations namespaces boxes sequences
-arrays strings html.elements io.streams.string quotations ;
+arrays strings html.elements io.streams.string
+quotations xml.data xml.writer ;
 IN: html.templates
 
 MIXIN: template
@@ -13,6 +14,8 @@ M: string call-template* write ;
 
 M: callable call-template* call ;
 
+M: xml call-template* write-xml ;
+
 M: object call-template* output-stream get stream-copy ;
 
 ERROR: template-error template error ;
@@ -43,17 +46,17 @@ SYMBOL: style
 : write-style ( -- )
     style get >string write ;
 
-SYMBOL: atom-feed
+SYMBOL: atom-feeds
 
-: set-atom-feed ( title url -- )
+: add-atom-feed ( title url -- )
-    2array atom-feed get >box ;
+    2array atom-feeds get push ;
 
-: write-atom-feed ( -- )
+: write-atom-feeds ( -- )
-    atom-feed get value>> [
+    atom-feeds get [
         <link "alternate" =rel "application/atom+xml" =type
-        [ first =title ] [ second =href ] bi
+        first2 [ =title ] [ =href ] bi*
         link/>
-    ] when* ;
+    ] each ;
 
 SYMBOL: nested-template?
 
@@ -66,9 +69,9 @@ M: f call-template* drop call-next-template ;
 
 : with-boilerplate ( body template -- )
     [
-        title get [ <box> title set ] unless
+        title [ <box> or ] change
-        atom-feed get [ <box> atom-feed set ] unless
+        style [ SBUF" " clone or ] change
-        style get [ SBUF" " clone style set ] unless
+        atom-feeds [ V{ } like ] change
 
         [
             [

extra/http/client/client-tests.factor

@@ -1,5 +1,5 @@
 USING: http.client http.client.private http tools.test
-tuple-syntax namespaces ;
+tuple-syntax namespaces urls ;
 [ "localhost" f ] [ "localhost" parse-host ] unit-test
 [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
 
@@ -10,11 +10,8 @@ tuple-syntax namespaces ;
 
 [
     TUPLE{ request
-        protocol: http
+        url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" query: H{ } }
         method: "GET"
-        host: "www.apple.com"
-        port: 80
-        path: "/index.html"
         version: "1.1"
         cookies: V{ }
         header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
@@ -28,11 +25,8 @@ tuple-syntax namespaces ;
 
 [
     TUPLE{ request
-        protocol: https
+        url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" query: H{ } }
         method: "GET"
-        host: "www.amazon.com"
-        port: 443
-        path: "/index.html"
         version: "1.1"
         cookies: V{ }
         header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }

extra/http/client/client.factor

@@ -27,8 +27,7 @@ SYMBOL: redirects
         redirects inc
         redirects get max-redirects < [
             request get
-            swap "location" header dup absolute-url?
+            swap "location" header request-with-url
-            [ request-with-url ] [ request-with-path ] if
             "GET" >>method http-request
         ] [
             too-many-redirects
@@ -51,7 +50,7 @@ PRIVATE>
 
 : http-request ( request -- response data )
     dup request [
-        dup request-addr latin1 [
+        dup url>> url-addr latin1 [
             1 minutes timeouts
             write-request
             read-response

extra/http/http-tests.factor

@@ -1,37 +1,13 @@
 USING: http tools.test multiline tuple-syntax
 io.streams.string kernel arrays splitting sequences
-assocs io.sockets db db.sqlite continuations ;
+assocs io.sockets db db.sqlite continuations urls ;
 IN: http.tests
 
-[ "hello%20world" ] [ "hello world" url-encode ] unit-test
-[ "hello world" ] [ "hello%20world" url-decode ] unit-test
-[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
-[ f ] [ "%XX%XX%XX" url-decode ] unit-test
-[ f ] [ "%XX%XX%X" url-decode ] unit-test
-
-[ "hello world"   ] [ "hello+world"    url-decode ] unit-test
-[ "hello world"   ] [ "hello%20world"  url-decode ] unit-test
-[ " ! "           ] [ "%20%21%20"      url-decode ] unit-test
-[ "hello world"   ] [ "hello world%"   url-decode ] unit-test
-[ "hello world"   ] [ "hello world%x"  url-decode ] unit-test
-[ "hello%20world" ] [ "hello world"    url-encode ] unit-test
-[ "%20%21%20"     ] [ " ! "            url-encode ] unit-test
-
-[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
-
 [ "/" ] [ "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
 
-[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
-
-[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
-
-[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
-
-[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
-
 : lf>crlf "\n" split "\r\n" join ;
 
 STRING: read-request-test-1
@@ -45,11 +21,8 @@ blah
 
 [
     TUPLE{ request
-        protocol: http
+        url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
-        port: 80
         method: "GET"
-        path: "/bar"
-        query: H{ }
         version: "1.1"
         header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
         post-data: "blah"
@@ -85,14 +58,10 @@ Host: www.sex.com
 
 [
     TUPLE{ request
-        protocol: http
+        url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" }
-        port: 80
         method: "HEAD"
-        path: "/bar"
-        query: H{ }
         version: "1.1"
         header: H{ { "host" "www.sex.com" } }
-        host: "www.sex.com"
         cookies: V{ }
     }
 ] [
@@ -101,6 +70,15 @@ Host: www.sex.com
     ] with-string-reader
 ] unit-test
 
+STRING: read-request-test-3
+GET nested HTTP/1.0
+
+;
+
+[ read-request-test-3 [ read-request ] with-string-reader ]
+[ "Bad request: URL" = ]
+must-fail-with
+
 STRING: read-response-test-1
 HTTP/1.1 404 not found
 Content-Type: text/html; charset=UTF8
@@ -145,14 +123,14 @@ read-response-test-1' 1array [
 ] unit-test
 
 ! Live-fire exercise
-USING: http.server http.server.static http.server.sessions
+USING: http.server http.server.static furnace.sessions
-http.server.actions http.server.auth.login http.server.db http.client
+furnace.actions furnace.auth.login furnace.db http.client
 io.server io.files io io.encodings.ascii
 accessors namespaces threads ;
 
 : add-quit-action
     <action>
-        [ stop-server [ "Goodbye" write ] <html-content> ] >>display
+        [ stop-server "Goodbye" "text/html" <content> ] >>display
     "quit" add-responder ;
 
 : test-db "test.db" temp-file sqlite-db ;
@@ -171,7 +149,7 @@ test-db [
                 "resource:extra/http/test" <static> >>default
             "nested" add-responder
             <action>
-                [ "redirect-loop" f <standard-redirect> ] >>display
+                [ URL" redirect-loop" <redirect> ] >>display
             "redirect-loop" add-responder
         main-responder set
 
@@ -186,16 +164,6 @@ test-db [
     "http://localhost:1237/nested/foo.html" http-get =
 ] unit-test
 
-! Try with a slightly malformed request
-[ t ] [
-    "localhost" 1237 <inet> ascii [
-        "GET nested HTTP/1.0\r\n" write flush
-        "\r\n" write flush
-        read-crlf drop
-        read-header
-    ] with-client "location" swap at "/" head?
-] unit-test
-
 [ "http://localhost:1237/redirect-loop" http-get ]
 [ too-many-redirects? ] must-fail-with
 
@@ -237,7 +205,7 @@ test-db [
 [ ] [
     [
         <dispatcher>
-            <action> [ [ "Hi" write ] <text-content> ] >>display
+            <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
             <login>
             <sessions>
             "" add-responder

extra/http/http.factor

@@ -7,88 +7,31 @@ strings vectors hashtables quotations arrays byte-arrays
 math.parser calendar calendar.format
 
 io io.streams.string io.encodings.utf8 io.encodings.string
-io.sockets io.sockets.secure
+io.sockets io.sockets.secure io.server
 
 unicode.case unicode.categories qualified
 
-html.templates ;
+urls html.templates ;
 
 EXCLUDE: fry => , ;
 
 IN: http
 
-SINGLETON: http
+: secure-protocol? ( protocol -- ? )
+    "https" = ;
 
-SINGLETON: https
+: url-addr ( url -- addr )
+    [ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
+    secure-protocol? [ <secure> ] when ;
 
-GENERIC: http-port ( protocol -- port )
+: protocol-port ( protocol -- port )
-
-M: http http-port drop 80 ;
-
-M: https http-port drop 443 ;
-
-GENERIC: protocol>string ( protocol -- string )
-
-M: http protocol>string drop "http" ;
-
-M: https protocol>string drop "https" ;
-
-: string>protocol ( string -- protocol )
     {
-        { "http" [ http ] }
+        { "http" [ 80 ] }
-        { "https" [ https ] }
+        { "https" [ 443 ] }
-        [ "Unknown protocol: " swap append throw ]
     } case ;
 
-: absolute-url? ( url -- ? )
+: ensure-port ( url -- url' )
-    [ "http://" head? ] [ "https://" head? ] bi or ;
+    dup protocol>> '[ , protocol-port or ] change-port ;
-
-: url-quotable? ( ch -- ? )
-    #! In a URL, can this character be used without
-    #! URL-encoding?
-    {
-        { [ dup letter? ] [ t ] }
-        { [ dup LETTER? ] [ t ] }
-        { [ dup digit? ] [ t ] }
-        { [ dup "/_-.:" member? ] [ t ] }
-        [ f ]
-    } cond nip ; foldable
-
-: push-utf8 ( ch -- )
-    1string utf8 encode
-    [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
-
-: url-encode ( str -- str )
-    [
-        [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
-    ] "" make ;
-
-: url-decode-hex ( index str -- )
-    2dup length 2 - >= [
-        2drop
-    ] [
-        [ 1+ dup 2 + ] dip subseq  hex> [ , ] when*
-    ] if ;
-
-: url-decode-% ( index str -- index str )
-    2dup url-decode-hex [ 3 + ] dip ;
-
-: url-decode-+-or-other ( index str ch -- index str )
-    dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
-
-: url-decode-iter ( index str -- )
-    2dup length >= [
-        2drop
-    ] [
-        2dup nth dup CHAR: % = [
-            drop url-decode-%
-        ] [
-            url-decode-+-or-other
-        ] if url-decode-iter
-    ] if ;
-
-: url-decode ( str -- str )
-    [ 0 swap url-decode-iter ] "" make utf8 decode ;
 
 : crlf "\r\n" write ;
 
@@ -130,6 +73,7 @@ M: https protocol>string drop "https" ;
     {
         { [ dup number? ] [ number>string ] }
         { [ dup timestamp? ] [ timestamp>http-string ] }
+        { [ dup url? ] [ url>string ] }
         { [ dup string? ] [ ] }
         { [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
     } cond ;
@@ -145,42 +89,6 @@ M: https protocol>string drop "https" ;
         header-value>string check-header-string write crlf
     ] assoc-each crlf ;
 
-: add-query-param ( value key assoc -- )
-    [
-        at [
-            {
-                { [ dup string? ] [ swap 2array ] }
-                { [ dup array? ] [ swap suffix ] }
-                { [ dup not ] [ drop ] }
-            } cond
-        ] when*
-    ] 2keep set-at ;
-
-: query>assoc ( query -- assoc )
-    dup [
-        "&" split H{ } clone [
-            [
-                [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
-                add-query-param
-            ] curry each
-        ] keep
-    ] when ;
-
-: assoc>query ( hash -- str )
-    [
-        {
-            { [ dup number? ] [ number>string 1array ] }
-            { [ dup string? ] [ 1array ] }
-            { [ dup sequence? ] [ ] }
-        } cond
-    ] assoc-map
-    [
-        [
-            [ url-encode ] dip
-            [ url-encode "=" swap 3append , ] with each
-        ] assoc-each
-    ] { } make "&" join ;
-
 TUPLE: cookie name value path domain expires max-age http-only ;
 
 : <cookie> ( value name -- cookie )
@@ -236,12 +144,8 @@ TUPLE: cookie name value path domain expires max-age http-only ;
     [ unparse-cookie ] map concat "; " join ;
 
 TUPLE: request
-protocol
-host
-port
 method
-path
+url
-query
 version
 header
 post-data
@@ -254,19 +158,15 @@ cookies ;
 : <request>
     request new
         "1.1" >>version
-        http >>protocol
+        <url>
+            "http" >>protocol
+            H{ } clone >>query
+        >>url
         H{ } clone >>header
-        H{ } clone >>query
         V{ } clone >>cookies
         "close" "connection" set-header
         "Factor http.client vocabulary" "user-agent" set-header ;
 
-: query-param ( request key -- value )
-    swap query>> at ;
-
-: set-query-param ( request value key -- request )
-    pick query>> set-at ;
-
 : chop-hostname ( str -- str' )
     ":" split1 "//" ?head drop nip
     CHAR: / over index over length or tail
@@ -284,21 +184,17 @@ cookies ;
     " " read-until [ "Bad request: method" throw ] unless
     >>method ;
 
-: read-query ( request -- request )
+: check-absolute ( url -- url )
-    " " read-until
+    dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
-    [ "Bad request: query params" throw ] unless
-    query>assoc >>query ;
 
 : read-url ( request -- request )
-    " ?" read-until {
+    " " read-until [
-        { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] }
+        dup empty? [ drop read-url ] [ >url check-absolute >>url ] if
-        { CHAR: ? [ url>path >>path read-query ] }
+    ] [ "Bad request: URL" throw ] if ;
-        [ "Bad request: URL" throw ]
-    } case ;
 
 : parse-version ( string -- version )
-    "HTTP/" ?head [ "Bad version" throw ] unless
+    "HTTP/" ?head [ "Bad request: version" throw ] unless
-    dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
+    dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ;
 
 : read-request-version ( request -- request )
     read-crlf [ CHAR: \s = ] left-trim
@@ -325,13 +221,11 @@ SYMBOL: max-post-request
 : read-post-data ( request -- request )
     dup header>> content-length [ read >>post-data ] when* ;
 
-: parse-host ( string -- host port )
-    "." ?tail drop ":" split1
-    dup [ string>number ] when ;
-
 : extract-host ( request -- request )
-    dup [ "host" header parse-host ] keep protocol>> http-port or
+    [ ] [ url>> ] [ "host" header parse-host ] tri
-    [ >>host ] [ >>port ] bi* ;
+    [ >>host ] [ >>port ] bi*
+    ensure-port
+    drop ;
 
 : extract-post-data-type ( request -- request )
     dup "content-type" header >>post-data-type ;
@@ -349,6 +243,9 @@ SYMBOL: max-post-request
 : parse-content-type ( content-type -- type encoding )
     ";" split1 parse-content-type-attributes "charset" swap at ;
 
+: detect-protocol ( request -- request )
+    dup url>> remote-address get secure? "https" "http" ? >>protocol drop ;
+
 : read-request ( -- request )
     <request>
     read-method
@@ -356,6 +253,7 @@ SYMBOL: max-post-request
     read-request-version
     read-request-header
     read-post-data
+    detect-protocol
     extract-host
     extract-post-data-type
     parse-post-data
@@ -364,15 +262,8 @@ SYMBOL: max-post-request
 : write-method ( request -- request )
     dup method>> write bl ;
 
-: (link>string) ( url query -- url' )
-    [ url-encode ] [ assoc>query ] bi*
-    dup empty? [ drop ] [ "?" swap 3append ] if ;
-
-: write-url ( request -- )
-    [ path>> ] [ query>> ] bi (link>string) write ;
-
 : write-request-url ( request -- request )
-    dup write-url bl ;
+    dup url>> relative-url url>string write bl ;
 
 : write-version ( request -- request )
     "HTTP/" write dup request-version write crlf ;
@@ -383,24 +274,13 @@ SYMBOL: max-post-request
         "application/x-www-form-urlencoded" >>post-data-type
     ] if ;
 
-GENERIC: protocol-addr ( request protocol -- addr )
+: url-host ( url -- string )
-
+    [ host>> ] [ port>> ] bi dup "http" protocol-port =
-M: object protocol-addr
-    drop [ host>> ] [ port>> ] bi <inet> ;
-
-M: https protocol-addr
-    call-next-method <secure> ;
-
-: request-addr ( request -- addr )
-    dup protocol>> protocol-addr ;
-
-: request-host ( request -- string )
-    [ host>> ] [ port>> ] bi dup http http-port =
     [ drop ] [ ":" swap number>string 3append ] if ;
 
 : write-request-header ( request -- request )
     dup header>> >hashtable
-    over host>> [ over request-host "host" pick set-at ] when
+    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-type>> [ "content-type" pick set-at ] when*
     over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
@@ -419,38 +299,8 @@ M: https protocol-addr
     flush
     drop ;
 
-: request-with-path ( request path -- request )
-    [ "/" prepend ] [ "/" ] if*
-    "?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ;
-
 : request-with-url ( request url -- request )
-    ":" split1
+    '[ , >url derive-url ensure-port ] change-url ;
-    [ string>protocol >>protocol ]
-    [
-        "//" ?head [ "Invalid URL" throw ] unless
-        "/" split1
-        [
-            parse-host [ >>host ] [ >>port ] bi*
-            dup protocol>> http-port '[ , or ] change-port
-        ]
-        [ request-with-path ]
-        bi*
-    ] bi* ;
-
-: request-url ( request -- url )
-    [
-        [
-            dup host>> [
-                [ protocol>> protocol>string write "://" write ]
-                [ host>> url-encode write ":" write ]
-                [ [ port>> ] [ protocol>> http-port or ] bi number>string write ]
-                tri
-            ] [ drop ] if
-        ]
-        [ path>> "/" head? [ "/" write ] unless ]
-        [ write-url ]
-        tri
-    ] with-string-writer ;
 
 GENERIC: write-response ( response -- )
 

extra/http/server/cgi/cgi.factor

@@ -14,13 +14,12 @@ IN: http.server.cgi
         "HTTP/" request get version>> append "SERVER_PROTOCOL" set
         "Factor" "SERVER_SOFTWARE" set
 
-        dup "PATH_TRANSLATED" set
+        [ "PATH_TRANSLATED" set ] [ "SCRIPT_FILENAME" set ] bi
-        "SCRIPT_FILENAME" set
 
-        request get path>> "SCRIPT_NAME" set
+        request get url>> path>> "SCRIPT_NAME" set
 
-        request get host>> "SERVER_NAME" set
+        request get url>> host>> "SERVER_NAME" set
-        request get port>> number>string "SERVER_PORT" set
+        request get url>> port>> number>string "SERVER_PORT" set
         "" "PATH_INFO" set
         "" "REMOTE_HOST" set
         "" "REMOTE_ADDR" set

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

@@ -1,4 +0,0 @@
-IN: http.server.db.tests
-USING: tools.test http.server.db ;
-
-\ <db-persistence> must-infer

extra/http/server/server-tests.factor

@@ -1,27 +1,52 @@
 USING: http.server tools.test kernel namespaces accessors
-io http math sequences assocs arrays classes words ;
+io http math sequences assocs arrays classes words urls ;
 IN: http.server.tests
 
 \ find-responder must-infer
 
 [
     <request>
-    http >>protocol
+        <url>
-    "www.apple.com" >>host
+            "http" >>protocol
-    "/xxx/bar" >>path
+            "www.apple.com" >>host
-    { { "a" "b" } } >>query
+            "/xxx/bar" >>path
+            { { "a" "b" } } >>query
+        >>url
     request set
 
     [ ] link-hook set
 
-    [ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test
+    [ "http://www.apple.com:80/xxx/bar" ] [ 
-    [ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test
+        <url> adjust-url url>string 
-    [ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test
+    ] unit-test
-    [ "http://www.apple.com:80/xxx/bar?c=d" ] [ f { { "c" "d" } } derive-url ] unit-test
+
-    [ "http://www.apple.com:80/flip?a=b" ] [ "/flip" f derive-url ] unit-test
+    [ "http://www.apple.com:80/xxx/baz" ] [
-    [ "http://www.apple.com:80/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test
+        <url> "baz" >>path adjust-url url>string
-    [ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test
+    ] unit-test
-    [ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] unit-test
+    
+    [ "http://www.apple.com:80/xxx/baz?c=d" ] [
+        <url> "baz" >>path { { "c" "d" } } >>query adjust-url url>string
+    ] unit-test
+    
+    [ "http://www.apple.com:80/xxx/bar?c=d" ] [
+        <url> { { "c" "d" } } >>query adjust-url url>string
+    ] unit-test
+    
+    [ "http://www.apple.com:80/flip" ] [
+        <url> "/flip" >>path adjust-url url>string
+    ] unit-test
+    
+    [ "http://www.apple.com:80/flip?c=d" ] [
+        <url> "/flip" >>path { { "c" "d" } } >>query adjust-url url>string
+    ] unit-test
+    
+    [ "http://www.jedit.org:80/" ] [
+        "http://www.jedit.org" >url adjust-url url>string
+    ] unit-test
+    
+    [ "http://www.jedit.org:80/?a=b" ] [
+        "http://www.jedit.org" >url { { "a" "b" } } >>query adjust-url url>string
+    ] unit-test
 ] with-scope
 
 TUPLE: mock-responder path ;
@@ -31,7 +56,7 @@ C: <mock-responder> mock-responder
 M: mock-responder call-responder*
     nip
     path>> on
-    [ ] <text-content> ;
+    [ ] "text/plain" <content> ;
 
 : check-dispatch ( tag path -- ? )
     H{ } clone base-paths set
@@ -84,7 +109,7 @@ C: <path-check-responder> path-check-responder
 
 M: path-check-responder call-responder*
     drop
-    >array <text-content> ;
+    >array "text/plain" <content> ;
 
 [ { "c" } ] [
     H{ } clone base-paths set
@@ -125,7 +150,7 @@ C: <base-path-check-responder> base-path-check-responder
 M: base-path-check-responder call-responder*
     2drop
     "$funny-dispatcher" resolve-base-path
-    <text-content> ;
+    "text/plain" <content> ;
 
 [ ] [
     <dispatcher>

extra/http/server/server.factor

@@ -2,23 +2,16 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel namespaces io io.timeouts strings splitting
 threads sequences prettyprint io.server logging calendar http
-html.streams html.elements accessors math.parser
+html.streams html.components html.elements html.templates
-combinators.lib tools.vocabs debugger continuations random
+accessors math.parser combinators.lib tools.vocabs debugger
-combinators destructors io.encodings.8-bit fry classes words
+continuations random combinators destructors io.streams.string
-math rss json.writer ;
+io.encodings.8-bit fry classes words math urls
+arrays vocabs.loader ;
 IN: http.server
 
 ! path is a sequence of path component strings
-
 GENERIC: call-responder* ( path responder -- response )
 
-: request-params ( request -- assoc )
-    dup method>> {
-        { "GET" [ query>> ] }
-        { "HEAD" [ query>> ] }
-        { "POST" [ post-data>> ] }
-    } case ;
-
 : <content> ( body content-type -- response )
     <response>
         200 >>code
@@ -26,21 +19,6 @@ GENERIC: call-responder* ( path responder -- response )
         swap >>content-type
         swap >>body ;
 
-: <text-content> ( body -- response )
-    "text/plain" <content> ;
-
-: <html-content> ( body -- response )
-    "text/html" <content> ;
-
-: <xml-content> ( body -- response )
-    "text/xml" <content> ;
-
-: <feed-content> ( feed -- response )
-    '[ , feed>xml ] "text/xml" <content> ;
-
-: <json-content> ( obj -- response )
-    '[ , >json ] "application/json" <content> ;
-
 TUPLE: trivial-responder response ;
 
 C: <trivial-responder> trivial-responder
@@ -55,7 +33,8 @@ M: trivial-responder call-responder* nip response>> call ;
     </html> ;
 
 : <trivial-response> ( code message -- response )
-    2dup '[ , , trivial-response-body ] <html-content>
+    2dup [ trivial-response-body ] with-string-writer
+    "text/html" <content>
         swap >>message
         swap >>code ;
 
@@ -69,7 +48,7 @@ SYMBOL: 404-responder
 
 [ <404> ] <trivial-responder> 404-responder set-global
 
-SYMBOL: base-paths
+SYMBOL: responder-nesting
 
 : invert-slice ( slice -- slice' )
     dup slice? [
@@ -78,86 +57,81 @@ SYMBOL: base-paths
         drop { }
     ] if ;
 
-: add-base-path ( path dispatcher -- )
+: vocab-path ( vocab -- path )
-    [ invert-slice ] [ class word-name ] bi*
+    dup vocab-dir vocab-append-path ;
-    base-paths get set-at ;
+
+: 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-base-path ] [ call-responder* ] 2bi ;
+    [ add-responder-path ] [ call-responder* ] 2bi ;
 
-SYMBOL: link-hook
+: nested-responders ( -- seq )
+    responder-nesting get assocs:values [ third ] map ;
 
-: add-link-hook ( quot -- )
+: each-responder ( quot -- )
-    link-hook [ compose ] change ; inline
+   nested-responders swap each ; inline
 
-: modify-query ( query -- query )
+: responder-path ( string -- pair )
-    link-hook get call ;
+    dup responder-nesting get at
-
-: base-path ( string -- path )
-    dup base-paths get at
     [ ] [ "No such responder: " swap append throw ] ?if ;
 
-: resolve-base-path ( string -- string' )
+: base-path ( string -- path )
-    "$" ?head [
+    responder-path first ;
+
+: template-path ( string -- path )
+    responder-path second ;
+
+: resolve-responder-path ( string quot -- string' )
+    [ "$" ?head ] dip '[
         [
-            "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
+            "/" split1 [ @ [ "/" % % ] each "/" % ] dip %
         ] "" make
-    ] when ;
+    ] when ; inline
 
-: link>string ( url query -- url' )
+: resolve-base-path ( string -- string' )
-    [ resolve-base-path ] [ modify-query ] bi* (link>string) ;
+    [ base-path ] resolve-responder-path ;
 
-: write-link ( url query -- )
+: resolve-template-path ( string -- string' )
-    link>string write ;
+    [ template-path ] resolve-responder-path ;
 
-SYMBOL: form-hook
+GENERIC: modify-query ( query responder -- query' )
 
-: add-form-hook ( quot -- )
+M: object modify-query drop ;
-    form-hook [ compose ] change ;
 
-: hidden-form-field ( -- )
+: adjust-url ( url -- url' )
-    form-hook get call ;
+    clone
+        [ dup [ modify-query ] each-responder ] change-query
+        [ resolve-base-path ] change-path
+    request get url>>
+        clone
+        f >>query
+    swap derive-url ensure-port ;
 
-: absolute-redirect ( to query -- url )
+: <custom-redirect> ( url code message -- response )
-    #! Same host.
+    <trivial-response>
-    request get clone
+        swap dup url? [ adjust-url ] when
-    swap [ >>query ] when*
+        "location" set-header ;
-    swap url-encode >>path
-    [ modify-query ] change-query
-    request-url ;
 
-: replace-last-component ( path with -- path' )
+\ <custom-redirect> DEBUG add-input-logging
-    [ "/" last-split1 drop "/" ] dip 3append ;
-
-: relative-redirect ( to query -- url )
-    request get clone
-    swap [ >>query ] when*
-    swap [ '[ , replace-last-component ] change-path ] when*
-    [ modify-query ] change-query
-    request-url ;
-
-: derive-url ( to query -- url )
-    {
-        { [ over "http://" head? ] [ link>string ] }
-        { [ over "/" head? ] [ absolute-redirect ] }
-        { [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] }
-        [ relative-redirect ]
-    } cond ;
-
-: <redirect> ( to query code message -- response )
-    <trivial-response> -rot derive-url "location" set-header ;
-
-\ <redirect> DEBUG add-input-logging
 
 : <permanent-redirect> ( to query -- response )
-    301 "Moved Permanently" <redirect> ;
+    301 "Moved Permanently" <custom-redirect> ;
 
 : <temporary-redirect> ( to query -- response )
-    307 "Temporary Redirect" <redirect> ;
+    307 "Temporary Redirect" <custom-redirect> ;
 
-: <standard-redirect> ( to query -- response )
+: <redirect> ( to query -- response )
-    request get method>> "POST" =
+    request get method>> {
-    [ <permanent-redirect> ] [ <temporary-redirect> ] if ;
+        { "GET" [ <temporary-redirect> ] }
+        { "HEAD" [ <temporary-redirect> ] }
+        { "POST" [ <permanent-redirect> ] }
+    } case ;
 
 TUPLE: dispatcher default responders ;
 
@@ -187,7 +161,7 @@ TUPLE: vhost-dispatcher default responders ;
     404-responder get H{ } clone vhost-dispatcher boa ;
 
 : find-vhost ( dispatcher -- responder )
-    request get host>> over responders>> at*
+    request get url>> host>> over responders>> at*
     [ nip ] [ drop default>> ] if ;
 
 M: vhost-dispatcher call-responder* ( path dispatcher -- response )
@@ -242,35 +216,28 @@ SYMBOL: development-mode
 LOG: httpd-hit NOTICE
 
 : log-request ( request -- )
-    { method>> host>> path>> } map-exec-with httpd-hit ;
+    [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ;
-
-SYMBOL: exit-continuation
-
-: exit-with exit-continuation get continue-with ;
-
-: with-exit-continuation ( quot -- )
-    '[ exit-continuation set @ ] callcc1 exit-continuation off ;
 
 : split-path ( string -- path )
     "/" split harvest ;
 
-: init-request ( -- )
+: init-request ( request -- )
-    H{ } clone base-paths set
+    request set
+    H{ } clone responder-nesting set
     [ ] link-hook set
     [ ] form-hook set ;
 
+: dispatch-request ( request -- response )
+    url>> path>> split-path main-responder get call-responder ;
+
 : do-request ( request -- response )
     [
-        init-request
+        [ init-request ]
-        [ request set ]
         [ log-request ]
-        [ path>> split-path main-responder get call-responder ] tri
+        [ dispatch-request ] tri
-        [ <404> ] unless*
+    ]
-    ] [
+    [ [ \ do-request log-error ] [ <500> ] bi ]
-        [ \ do-request log-error ]
+    recover ;
-        [ <500> ]
-        bi
-    ] recover ;
 
 : ?refresh-all ( -- )
     development-mode get-global

extra/http/server/static/static.factor

@@ -4,7 +4,7 @@ USING: calendar io io.files kernel math math.order
 math.parser http http.server namespaces parser sequences strings
 assocs hashtables debugger http.mime sorting html.elements
 html.templates.fhtml logging calendar.format accessors
-io.encodings.binary fry xml.entities destructors ;
+io.encodings.binary fry xml.entities destructors urls ;
 IN: http.server.static
 
 ! special maps mime types to quots with effect ( path -- )
@@ -71,7 +71,7 @@ TUPLE: file-responder root hook special allow-listings ;
 
 : list-directory ( directory -- response )
     file-responder get allow-listings>> [
-        '[ , directory. ] <html-content>
+        '[ , directory. ] "text/html" <content>
     ] [
         drop <403>
     ] if ;
@@ -85,7 +85,7 @@ TUPLE: file-responder root hook special allow-listings ;
         find-index [ serve-file ] [ list-directory ] ?if
     ] [
         drop
-        request get path>> "/" append f <standard-redirect>
+        request get url>> clone [ "/" append ] change-path <redirect>
     ] if ;
 
 : serve-object ( filename -- response )
@@ -101,6 +101,6 @@ M: file-responder call-responder* ( path responder -- response )
 
 ! file responder integration
 : enable-fhtml ( responder -- responder )
-    [ <fhtml> <html-content> ]
+    [ <fhtml> "text/html" <content> ]
     "application/x-factor-server-page"
     pick special>> set-at ;

extra/io/pools/pools.factor

@@ -1,13 +1,22 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel arrays namespaces sequences continuations
-destructors io.sockets ;
+destructors io.sockets alien alien.syntax ;
 IN: io.pools
 
-TUPLE: pool connections disposed ;
+TUPLE: pool connections disposed expired ;
+
+: check-pool ( pool -- )
+    dup check-disposed
+    dup expired>> expired? [
+        ALIEN: 31337 >>expired
+        connections>> [ delete-all ] [ dispose-each ] bi
+    ] [ drop ] if ;
 
 : <pool> ( class -- pool )
-    new V{ } clone >>connections ; inline
+    new V{ } clone
+        >>connections
+        dup check-pool ; inline
 
 M: pool dispose* connections>> dispose-each ;
 
@@ -17,15 +26,14 @@ M: pool dispose* connections>> dispose-each ;
 TUPLE: return-connection conn pool ;
 
 : return-connection ( conn pool -- )
-    dup check-disposed connections>> push ;
+    dup check-pool connections>> push ;
 
 GENERIC: make-connection ( pool -- conn )
 
 : new-connection ( pool -- )
-    [ make-connection ] keep return-connection ;
+    dup check-pool [ make-connection ] keep return-connection ;
 
 : acquire-connection ( pool -- conn )
-    dup check-disposed
     [ dup connections>> empty? ] [ dup new-connection ] [ ] while
     connections>> pop ;
 

extra/lcs/diff2html/diff2html.factor

@@ -38,7 +38,7 @@ M: delete diff-line
     </tr> ;
 
 : htmlize-diff ( diff -- )
-    <table "comparison" =class table>
+    <table "100%" =width "comparison" =class table>
         <tr> <th> "Old" write </th> <th> "New" write </th> </tr>
         [ diff-line ] each
     </table> ;

extra/rss/rss.factor

@@ -4,7 +4,7 @@ USING: xml.utilities kernel assocs xml.generator math.order
     strings sequences xml.data xml.writer
     io.streams.string combinators xml xml.entities io.files io
     http.client namespaces xml.generator hashtables
-    calendar.format accessors continuations ;
+    calendar.format accessors continuations urls ;
 IN: rss
 
 : any-tag-named ( tag names -- tag-inside )
@@ -103,18 +103,15 @@ C: <entry> entry
 
 : entry, ( entry -- )
     "entry" [
-        dup entry-title "title" { { "type" "html" } } simple-tag*,
+        dup title>> "title" { { "type" "html" } } simple-tag*,
-        "link" over entry-link "href" associate contained*,
+        "link" over link>> dup url? [ url>string ] when "href" associate contained*,
-        dup entry-pub-date timestamp>rfc3339 "published" simple-tag,
+        dup pub-date>> timestamp>rfc3339 "published" simple-tag,
-        entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
+        description>> [ "content" { { "type" "html" } } simple-tag*, ] when*
     ] tag, ;
 
 : feed>xml ( feed -- xml )
     "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
-        dup feed-title "title" simple-tag,
+        dup title>> "title" simple-tag,
-        "link" over feed-link "href" associate contained*,
+        "link" over link>> dup url? [ url>string ] when "href" associate contained*,
-        feed-entries [ entry, ] each
+        entries>> [ entry, ] each
     ] make-xml* ;
-
-: write-feed ( feed -- )
-    feed>xml write-xml ;

extra/tangle/tangle.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs db db.sqlite db.postgresql http http.server http.server.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ;
+USING: accessors assocs db db.sqlite db.postgresql http http.server furnace.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ;
 IN: tangle
 
 GENERIC: render* ( content templater -- output )
@@ -20,7 +20,7 @@ C: <tangle> tangle
     [ [ db>> ] [ seq>> ] bi ] dip with-db ;
 
 : node-response ( id -- response )
-    load-node [ node-content <text-content> ] [ <404> ] if* ;
+    load-node [ node-content "text/plain" <content> ] [ <404> ] if* ;
 
 : display-node ( params -- response )
     [
@@ -36,7 +36,7 @@ C: <tangle> tangle
 : submit-node ( params -- response )
     [
         "node_content" swap at* [
-            create-node id>> number>string <text-content>
+            create-node id>> number>string "text/plain" <content>
         ] [
             drop <400>
         ] if
@@ -52,7 +52,7 @@ TUPLE: path-responder ;
 C: <path-responder> path-responder
 
 M: path-responder call-responder* ( path responder -- response )
-    drop path>file [ node-content <text-content> ] [ <404> ] if* ;
+    drop path>file [ node-content "text/plain" <content> ] [ <404> ] if* ;
 
 TUPLE: tangle-dispatcher < dispatcher tangle ;
 

extra/urls/urls-tests.factor

@@ -77,10 +77,17 @@ USING: urls tools.test tuple-syntax arrays kernel assocs ;
             }
             "a/relative/path"
         }
+        {
+            TUPLE{ url
+                path: "bar"
+                query: H{ { "a" "b" } }
+            }
+            "bar?a=b"
+        }
     } ;
 
 urls [
-    [ 1array ] [ [ string>url ] curry ] bi* unit-test
+    [ 1array ] [ [ >url ] curry ] bi* unit-test
 ] assoc-each
 
 urls [
@@ -192,3 +199,7 @@ urls [
 
     derive-url
 ] unit-test
+
+[ "a" ] [
+    <url> "a" "b" set-query-param "b" query-param
+] unit-test

extra/urls/urls.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel unicode.categories combinators sequences splitting
-fry namespaces assocs arrays strings mirrors
+fry namespaces assocs arrays strings io.encodings.string
-io.encodings.string io.encodings.utf8
+io.encodings.utf8 math math.parser accessors mirrors parser
-math math.parser accessors namespaces.lib ;
+prettyprint.backend hashtables ;
 IN: urls
 
 : url-quotable? ( ch -- ? )
@@ -91,11 +91,13 @@ IN: urls
 
 TUPLE: url protocol host port path query anchor ;
 
+: <url> ( -- url ) url new ;
+
 : query-param ( request key -- value )
     swap query>> at ;
 
 : set-query-param ( request value key -- request )
-    pick query>> set-at ;
+    '[ , , _ ?set-at ] change-query ;
 
 : parse-host ( string -- host port )
     ":" split1 [ url-decode ] [
@@ -105,40 +107,44 @@ TUPLE: url protocol host port path query anchor ;
         ] when
     ] bi* ;
 
-: parse-host-part ( protocol rest -- string' )
+: parse-host-part ( url protocol rest -- url string' )
-    [ "protocol" set ] [
+    [ >>protocol ] [
         "//" ?head [ "Invalid URL" throw ] unless
         "/" split1 [
-            parse-host [ "host" set ] [ "port" set ] bi*
+            parse-host [ >>host ] [ >>port ] bi*
         ] [ "/" prepend ] bi*
     ] bi* ;
 
-: string>url ( string -- url )
+GENERIC: >url ( obj -- url )
-    [
-        ":" split1 [ parse-host-part ] when*
-        "#" split1 [
-            "?" split1 [ query>assoc "query" set ] when*
-            url-decode "path" set
-        ] [
-            url-decode "anchor" set
-        ] bi*
-    ] url make-object ;
 
-: unparse-host-part ( protocol -- )
+M: url >url ;
+
+M: string >url
+    <url> swap
+    ":" split1 [ parse-host-part ] when*
+    "#" split1 [
+        "?" split1
+        [ url-decode >>path ]
+        [ [ query>assoc >>query ] when* ] bi*
+    ]
+    [ url-decode >>anchor ] bi* ;
+
+: unparse-host-part ( url protocol -- )
     %
     "://" %
-    "host" get url-encode %
+    [ host>> url-encode % ]
-    "port" get [ ":" % # ] when*
+    [ port>> [ ":" % # ] when* ]
-    "path" get "/" head? [ "Invalid URL" throw ] unless ;
+    [ path>> "/" head? [ "/" % ] unless ]
+    tri ;
 
 : url>string ( url -- string )
     [
-        <mirror> [
+        {
-            "protocol" get [ unparse-host-part ] when*
+            [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
-            "path" get url-encode %
+            [ path>> url-encode % ]
-            "query" get [ "?" % assoc>query % ] when*
+            [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
-            "anchor" get [ "#" % url-encode % ] when*
+            [ anchor>> [ "#" % url-encode % ] when* ]
-        ] bind
+        } cleave
     ] "" make ;
 
 : url-append-path ( path1 path2 -- path )
@@ -158,3 +164,7 @@ TUPLE: url protocol host port path query anchor ;
 
 : relative-url ( url -- url' )
     clone f >>protocol f >>host f >>port ;
+
+: URL" lexer get skip-blank parse-string >url parsed ; parsing
+
+M: url pprint* dup url>string "URL\" " "\"" pprint-string ;

extra/webapps/counter/counter.factor

@@ -1,6 +1,6 @@
-USING: math kernel accessors html.components
+USING: math kernel accessors html.components http.server
-http.server http.server.actions
+furnace.actions furnace.sessions html.templates.chloe
-http.server.sessions html.templates.chloe fry ;
+fry urls ;
 IN: webapps.counter
 
 SYMBOL: count
@@ -11,15 +11,15 @@ M: counter-app init-session* drop 0 count sset ;
 
 : <counter-action> ( quot -- action )
     <action>
-        swap '[ count , schange "" f <standard-redirect> ] >>submit ;
+        swap '[
-
+            count , schange
-: counter-template ( -- template )
+            URL" $counter-app" <redirect>
-    "resource:extra/webapps/counter/counter.xml" <chloe> ;
+        ] >>submit ;
 
 : <display-action> ( -- action )
     <page-action>
         [ count sget "counter" set-value ] >>init
-        counter-template >>template ;
+        "$counter-app/counter" >>template ;
 
 : <counter-app> ( -- responder )
     counter-app new-dispatcher

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

@@ -4,13 +4,12 @@ USING: accessors kernel sequences assocs io.files io.sockets
 io.server
 namespaces db db.sqlite smtp
 http.server
-http.server.db
+furnace.db
-http.server.flows
+furnace.flows
-http.server.sessions
+furnace.sessions
-http.server.auth.login
+furnace.auth.login
-http.server.auth.providers.db
+furnace.auth.providers.db
-http.server.boilerplate
+furnace.boilerplate
-html.templates.chloe
 webapps.pastebin
 webapps.planet
 webapps.todo
@@ -20,9 +19,6 @@ IN: webapps.factor-website
 
 : test-db "resource:test.db" sqlite-db ;
 
-: factor-template ( path -- template )
-    "resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
-
 : init-factor-db ( -- )
     test-db [
         init-users-table
@@ -40,8 +36,10 @@ IN: webapps.factor-website
         init-revisions-table
     ] with-db ;
 
+TUPLE: factor-website < dispatcher ;
+
 : <factor-website> ( -- responder )
-    <dispatcher> 
+    factor-website new-dispatcher 
         <todo-list> "todo" add-responder
         <pastebin> "pastebin" add-responder
         <planet-factor> "planet" add-responder
@@ -53,7 +51,7 @@ IN: webapps.factor-website
         allow-password-recovery
         allow-edit-profile
     <boilerplate>
-        "page" factor-template >>template
+        "$factor-website/page" >>template
     <flows>
     <sessions>
     test-db <db-persistence> ;

extra/webapps/factor-website/page.xml

@@ -15,6 +15,8 @@
 			<t:style t:include="resource:extra/webapps/factor-website/page.css" />
 
 			<t:write-style />
+
+			<t:write-atom />
 		</head>
 
 		<body>

extra/webapps/pastebin/paste.xml

@@ -2,7 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:atom t:title="Paste - Atom" t:href="$pastebin/paste.atom" t:query="id" />
+	<t:atom t:title="This paste" t:href="$pastebin/paste.atom" t:query="id" />
 
 	<t:title>Paste: <t:label t:name="summary" /></t:title>
 
@@ -12,15 +12,13 @@
 		<tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
 	</table>
 
-	<pre class="description"><t:code t:name="contents" t:mode="modes" /></pre>
+	<pre class="description"><t:code t:name="contents" t:mode="mode" /></pre>
 
 	<t:button t:action="$pastebin/delete-paste" t:for="id" class="link-button link">Delete Paste</t:button>
-	|
-	<t:a t:href="$pastebin/annotate" t:query="id">Annotate</t:a>
 
-	<t:each-tuple t:values="annotations">
+	<t:bind-each t:name="annotations">
 
-		<h2>Annotation: <t:label t:name="summary" /></h2>
+		<a name="@id"><h2>Annotation: <t:label t:name="summary" /></h2></a>
 
 		<table>
 			<tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr>
@@ -32,9 +30,9 @@
 
 		<t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
 
-	</t:each-tuple>
+	</t:bind-each>
 
-	<t:bind-assoc t:name="new-annotation">
+	<t:bind t:name="new-annotation">
 
 		<h2>New Annotation</h2>
 
@@ -55,6 +53,6 @@
 			<input type="SUBMIT" value="Done" />
 		</t:form>
 
-	</t:bind-assoc>
+	</t:bind>
 
 </t:chloe>

extra/webapps/pastebin/pastebin-common.xml

@@ -2,6 +2,8 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
+	<t:atom t:title="Pastebin" t:href="$pastebin/list.atom" />
+
 	<t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
 
 	<div class="navbar">

extra/webapps/pastebin/pastebin.factor

@@ -2,13 +2,13 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs sorting sequences kernel accessors
 hashtables sequences.lib db.types db.tuples db combinators
-calendar calendar.format math.parser rss xml.writer
+calendar calendar.format math.parser rss urls xml.writer
 xmode.catalog validators html.components html.templates.chloe
 http.server
-http.server.actions
+furnace.actions
-http.server.auth
+furnace.auth
-http.server.auth.login
+furnace.auth.login
-http.server.boilerplate ;
+furnace.boilerplate ;
 IN: webapps.pastebin
 
 ! ! !
@@ -58,28 +58,31 @@ annotation "ANNOTATIONS"
 : paste ( id -- paste )
     <paste> select-tuple fetch-annotations ;
 
-: <id-redirect> ( id next -- response )
-    swap "id" associate <standard-redirect> ;
-
 ! ! !
 ! LINKS, ETC
 ! ! !
 
 : pastebin-link ( -- url )
-    "$pastebin/list" f link>string ;
+    URL" $pastebin/list" ;
 
 GENERIC: entity-link ( entity -- url )
 
+: paste-link ( id -- url )
+    <url>
+        "$pastebin/paste" >>path
+        swap "id" set-query-param ;
+
 M: paste entity-link
-    id>> "id" associate "$pastebin/paste" swap link>string ;
+    id>> paste-link ;
+
+: annotation-link ( parent id -- url )
+    <url>
+        "$pastebin/paste" >>path
+        swap number>string >>anchor
+        swap "id" set-query-param ;
 
 M: annotation entity-link
-    [ parent>> "parent" associate "$pastebin/paste" swap link>string ]
+    [ parent>> ] [ id>> ] bi annotation-link ;
-    [ id>> number>string "#" prepend ] bi
-    append ;
-
-: pastebin-template ( name -- template )
-    "resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
 
 ! ! !
 ! PASTE LIST
@@ -88,7 +91,7 @@ M: annotation entity-link
 : <pastebin-action> ( -- action )
     <page-action>
         [ pastes "pastes" set-value ] >>init
-        "pastebin" pastebin-template >>template ;
+        "$pastebin/pastebin" >>template ;
 
 : pastebin-feed-entries ( seq -- entries )
     <reversed> 20 short head [
@@ -96,7 +99,7 @@ M: annotation entity-link
             swap
             [ summary>> >>title ]
             [ date>> >>pub-date ]
-            [ entity-link >>link ]
+            [ entity-link adjust-url >>link ]
             tri
     ] map ;
 
@@ -117,7 +120,7 @@ M: annotation entity-link
     <page-action>
         [
             validate-integer-id
-            "id" value paste from-tuple
+            "id" value paste from-object
 
             "id" value
             "new-annotation" [
@@ -127,7 +130,7 @@ M: annotation entity-link
             ] nest-values
         ] >>init
 
-        "paste" pastebin-template >>template ;
+        "$pastebin/paste" >>template ;
 
 : paste-feed-entries ( paste -- entries )
     fetch-annotations annotations>> pastebin-feed-entries ;
@@ -135,15 +138,15 @@ M: annotation entity-link
 : paste-feed ( paste -- feed )
     feed new
         swap
-        [ "Paste #" swap id>> number>string append >>title ]
+        [ "Paste " swap id>> number>string append >>title ]
-        [ entity-link >>link ]
+        [ entity-link adjust-url >>link ]
         [ paste-feed-entries >>entries ]
         tri ;
 
 : <paste-feed-action> ( -- action )
     <feed-action>
         [ validate-integer-id ] >>init
-        [ "id" value paste annotations>> paste-feed ] >>feed ;
+        [ "id" value paste paste-feed ] >>feed ;
 
 : validate-entity ( -- )
     {
@@ -165,7 +168,7 @@ M: annotation entity-link
             mode-names "modes" set-value
         ] >>init
 
-        "new-paste" pastebin-template >>template
+        "$pastebin/new-paste" >>template
 
         [
             validate-entity
@@ -173,7 +176,7 @@ M: annotation entity-link
             f <paste>
             [ deposit-entity-slots ]
             [ insert-tuple ]
-            [ id>> "$pastebin/paste" <id-redirect> ]
+            [ id>> paste-link <redirect> ]
             tri
         ] >>submit ;
 
@@ -184,7 +187,7 @@ M: annotation entity-link
         [
             "id" value <paste> delete-tuples
             "id" value f <annotation> delete-tuples
-            "$pastebin/list" f <permanent-redirect>
+            URL" $pastebin/list" <redirect>
         ] >>submit ;
 
 ! ! !
@@ -192,10 +195,10 @@ M: annotation entity-link
 ! ! !
 
 : <new-annotation-action> ( -- action )
-    <page-action>
+    <action>
         [
             { { "id" [ v-integer ] } } validate-params
-            "id" value "$pastebin/paste" <id-redirect>
+            "id" value paste-link <redirect>
         ] >>display
 
         [
@@ -207,10 +210,7 @@ M: annotation entity-link
             "id" value f <annotation>
             [ deposit-entity-slots ]
             [ insert-tuple ]
-            [
+            [ entity-link <redirect> ]
-                ! Add anchor here
-                parent>> "$pastebin/paste" <id-redirect>
-            ]
             tri
         ] >>submit ;
 
@@ -221,7 +221,7 @@ M: annotation entity-link
         [
             f "id" value <annotation> select-tuple
             [ delete-tuples ]
-            [ parent>> "$pastebin/paste" <id-redirect> ]
+            [ parent>> paste-link <redirect> ]
             bi
         ] >>submit ;
 
@@ -242,7 +242,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-common" pastebin-template >>template ;
+        "$pastebin/pastebin-common" >>template ;
 
 : init-pastes-table \ paste ensure-table ;
 

extra/webapps/pastebin/pastebin.xml

@@ -2,8 +2,6 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:atom t:title="Pastebin - Atom" t:href="$pastebin/list.atom" />
-
 	<t:title>Pastebin</t:title>
 
 	<table width="100%">
@@ -11,13 +9,13 @@
 		<th align="left" width="100">Paste by:</th>
 		<th align="left" width="200">Date:</th>
 
-		<t:each-tuple t:values="pastes">
+		<t:bind-each t:name="pastes">
 			<tr>
 				<td><t:a t:href="$pastebin/paste" t:query="id"><t:label t:name="summary" /></t:a></td>
 				<td><t:label t:name="author" /></td>
 				<td><t:label t:name="date" /></td>
 			</tr>
-		</t:each-tuple>
+		</t:bind-each>
 	</table>
 
 </t:chloe>

extra/webapps/planet/admin.xml

@@ -5,13 +5,13 @@
 	<t:title>Planet Factor Administration</t:title>
 
 	<ul>
-		<t:each-tuple t:values="blogroll">
+		<t:bind-each t:name="blogroll">
 			<li>
 				<t:a t:href="$planet-factor/admin/edit-blog" t:query="id">
 					<t:label t:name="name" />
 				</t:a>
 			</li>
-		</t:each-tuple>
+		</t:bind-each>
 	</ul>
 
 	<p>

extra/webapps/planet/mini-planet.xml

@@ -2,13 +2,13 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:each-tuple t:values="postings">
+	<t:bind-each t:name="postings">
 
 		<p class="news">
 			<strong><t:view t:component="title" /></strong> <br/>
 			<t:a value="link" t:session="none" class="more">Read More...</t:a>
 		</p>
 
-	</t:each-tuple>
+	</t:bind-each>
 
 </t:chloe>

extra/webapps/planet/planet.factor

@@ -3,19 +3,16 @@
 USING: kernel accessors sequences sorting math math.order
 calendar alarms logging concurrency.combinators namespaces
 sequences.lib db.types db.tuples db fry locals hashtables
-html.components html.templates.chloe
+html.components
-rss xml.writer
+rss urls xml.writer
 validators
 http.server
-http.server.actions
+furnace.actions
-http.server.boilerplate
+furnace.boilerplate
-http.server.auth.login
+furnace.auth.login
-http.server.auth ;
+furnace.auth ;
 IN: webapps.planet
 
-: planet-template ( name -- template )
-    "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
-
 TUPLE: blog id name www-url feed-url ;
 
 M: blog link-title name>> ;
@@ -61,7 +58,7 @@ posting "POSTINGS"
 : <edit-blogroll-action> ( -- action )
     <page-action>
         [ blogroll "blogroll" set-value ] >>init
-        "admin" planet-template >>template ;
+        "$planet-factor/admin" >>template ;
 
 : <planet-action> ( -- action )
     <page-action>
@@ -70,7 +67,7 @@ posting "POSTINGS"
             postings "postings" set-value
         ] >>init
 
-        "planet" planet-template >>template ;
+        "$planet-factor/planet" >>template ;
 
 : planet-feed ( -- feed )
     feed new
@@ -110,7 +107,7 @@ posting "POSTINGS"
     <action>
         [
             update-cached-postings
-            "" f <permanent-redirect>
+            URL" $planet-factor/admin" <redirect>
         ] >>submit ;
 
 : <delete-blog-action> ( -- action )
@@ -119,7 +116,7 @@ posting "POSTINGS"
 
         [
             "id" value <blog> delete-tuples
-            "$planet-factor/admin" f <standard-redirect>
+            URL" $planet-factor/admin" <redirect>
         ] >>submit ;
 
 : validate-blog ( -- )
@@ -129,15 +126,12 @@ posting "POSTINGS"
         { "feed-url" [ v-url ] }
     } validate-params ;
 
-: <id-redirect> ( id next -- response )
-    swap "id" associate <standard-redirect> ;
-
 : deposit-blog-slots ( blog -- )
     { "name" "www-url" "feed-url" } deposit-slots ;
 
 : <new-blog-action> ( -- action )
     <page-action>
-        "new-blog" planet-template >>template
+        "$planet-factor/new-blog" >>template
 
         [ validate-blog ] >>validate
 
@@ -145,7 +139,12 @@ posting "POSTINGS"
             f <blog>
             [ deposit-blog-slots ]
             [ insert-tuple ]
-            [ id>> "$planet-factor/admin/edit-blog" <id-redirect> ]
+            [
+                <url>
+                    "$planet-factor/admin/edit-blog" >>path
+                    swap id>> "id" set-query-param
+                <redirect>
+            ]
             tri
         ] >>submit ;
     
@@ -153,10 +152,10 @@ posting "POSTINGS"
     <page-action>
         [
             validate-integer-id
-            "id" value <blog> select-tuple from-tuple
+            "id" value <blog> select-tuple from-object
         ] >>init
 
-        "edit-blog" planet-template >>template
+        "$planet-factor/edit-blog" >>template
 
         [
             validate-integer-id
@@ -167,7 +166,12 @@ posting "POSTINGS"
             f <blog>
             [ deposit-blog-slots ]
             [ update-tuple ]
-            [ id>> "$planet-factor/admin" <id-redirect> ]
+            [
+                <url>
+                    "$planet-factor/admin" >>path
+                    swap id>> "id" set-query-param
+                <redirect>
+            ]
             tri
         ] >>submit ;
 
@@ -193,7 +197,7 @@ TUPLE: planet-factor < dispatcher ;
         <feed-action> "feed.xml" add-responder
         <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
     <boilerplate>
-        "planet-common" planet-template >>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

@@ -8,7 +8,7 @@
 		<tr>
 			<td>
 
-				<t:each-tuple t:values="postings">
+				<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>
@@ -22,7 +22,7 @@
 						<t:a t:value="link" t:session="none"><t:label t:name="pub-date" /></t:a>
 					</p>
 
-				</t:each-tuple>
+				</t:bind-each>
 
 			</td>
 
@@ -31,7 +31,7 @@
 				<h2>Blogroll</h2>
 
 				<ul>
-					<t:each t:values="blogroll">
+					<t:each t:name="blogroll">
 						<li>
 							<t:link t:name="value"/>
 						</li>

extra/webapps/todo/edit-todo.xml

@@ -14,12 +14,8 @@
 		<input type="SUBMIT" value="Done" />
 	</t:form>
 
-	<t:if t:value="id">
+	<t:a t:href="$todo-list/view" t:query="id">View</t:a>
-	
+	|
-		<t:a t:href="$todo-list/view" t:query="id">View</t:a>
+	<t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
-		|
-		<t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
-		
-	</t:if>
 
 </t:chloe>

extra/webapps/todo/new-todo.xml

@@ -0,0 +1,17 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>New Item</t:title>
+
+	<t:form t:action="$todo-list/new">
+		<table>
+			<tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
+			<tr><th class="field-label">Priority: </th><td><t:field t:name="priority" /></td></tr>
+			<tr><th class="field-label big-field-label">Description:</th><td><t:textarea t:name="description" t:rows="20" t:cols="60" /></td></tr>
+		</table>
+
+		<input type="SUBMIT" value="Done" />
+	</t:form>
+
+</t:chloe>

extra/webapps/todo/todo-list.xml

@@ -13,7 +13,7 @@
 			<th>Edit</th>
 		</tr>
 
-		<t:each-tuple t:values="items">
+		<t:bind-each t:name="items">
 
 			<tr>
 				<td>
@@ -30,7 +30,7 @@
 				</td>
 			</tr>
 
-		</t:each-tuple>
+		</t:bind-each>
 
 	</table>
 

extra/webapps/todo/todo.factor

@@ -1,15 +1,15 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences namespaces
-db db.types db.tuples validators hashtables
+db db.types db.tuples validators hashtables urls
 html.components
 html.templates.chloe
-http.server.sessions
+furnace.sessions
-http.server.boilerplate
+furnace.boilerplate
-http.server.auth
+furnace.auth
-http.server.actions
+furnace.actions
-http.server.db
+furnace.db
-http.server.auth.login
+furnace.auth.login
 http.server ;
 IN: webapps.todo
 
@@ -31,20 +31,14 @@ todo "TODO"
         swap >>id
         uid >>uid ;
 
-: todo-template ( name -- template )
-    "resource:extra/webapps/todo/" swap ".xml" 3append <chloe> ;
-
 : <view-action> ( -- action )
     <page-action>
         [
             validate-integer-id
-            "id" value <todo> select-tuple from-tuple
+            "id" value <todo> select-tuple from-object
         ] >>init
         
-        "view-todo" todo-template >>template ;
+        "$todo-list/view-todo" >>template ;
-
-: <id-redirect> ( id next -- response )
-    swap "id" associate <standard-redirect> ;
 
 : validate-todo ( -- )
     {
@@ -57,15 +51,20 @@ todo "TODO"
     <page-action>
         [ 0 "priority" set-value ] >>init
 
-        "edit-todo" todo-template >>template
+        "$todo-list/new-todo" >>template
 
         [ validate-todo ] >>validate
 
         [
             f <todo>
-                dup { "summary" "description" } deposit-slots
+                dup { "summary" "priority" "description" } deposit-slots
             [ insert-tuple ]
-            [ id>> "$todo-list/view" <id-redirect> ]
+            [
+                <url>
+                    "$todo-list/view" >>path
+                    swap id>> "id" set-query-param
+                <redirect>
+            ]
             bi
         ] >>submit ;
 
@@ -73,10 +72,10 @@ todo "TODO"
     <page-action>
         [
             validate-integer-id
-            "id" value <todo> select-tuple from-tuple
+            "id" value <todo> select-tuple from-object
         ] >>init
 
-        "edit-todo" todo-template >>template
+        "$todo-list/edit-todo" >>template
 
         [
             validate-integer-id
@@ -87,7 +86,12 @@ todo "TODO"
             f <todo>
                 dup { "id" "summary" "priority" "description" } deposit-slots
             [ update-tuple ]
-            [ id>> "$todo-list/view" <id-redirect> ]
+            [
+                <url>
+                    "$todo-list/view" >>path
+                    swap id>> "id" set-query-param
+                <redirect>
+            ]
             bi
         ] >>submit ;
 
@@ -97,13 +101,13 @@ todo "TODO"
 
         [
             "id" get <todo> delete-tuples
-            "$todo-list/list" f <standard-redirect>
+            URL" $todo-list/list" <redirect>
         ] >>submit ;
 
 : <list-action> ( -- action )
     <page-action>
         [ f <todo> select-tuples "items" set-value ] >>init
-        "todo-list" todo-template >>template ;
+        "$todo-list/todo-list" >>template ;
 
 TUPLE: todo-list < dispatcher ;
 
@@ -115,5 +119,5 @@ TUPLE: todo-list < dispatcher ;
         <edit-action>   "edit"   add-responder
         <delete-action> "delete" add-responder
     <boilerplate>
-        "todo" todo-template >>template
+        "$todo-list/todo" >>template
     f <protected> ;

extra/webapps/todo/todo.xml

@@ -6,7 +6,7 @@
 
 	<div class="navbar">
 		  <t:a t:href="$todo-list/list">List Items</t:a>
-		| <t:a t:href="$todo-list/edit">Add Item</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:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>

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

@@ -35,7 +35,11 @@
 	
 	<tr>
 		<th class="field-label big-field-label">Capabilities:</th>
-		<td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
+		<td>
+			<t:each t:name="capabilities">
+				<t:checkbox t:name="@value" t:label="@value" /><br/>
+			</t:each>
+		</td>
 	</tr>
 	
 	<tr>

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

@@ -35,7 +35,11 @@
 	
 	<tr>
 		<th class="field-label big-field-label">Capabilities:</th>
-		<td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
+		<td>
+			<t:each t:name="capabilities">
+				<li><t:checkbox t:name="@value" t:label="@value" /><br/>
+			</t:each>
+		</td>
 	</tr>
 
 	</table>

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

@@ -1,45 +1,55 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences accessors namespaces combinators words
-assocs db.tuples arrays splitting strings validators
+assocs db.tuples arrays splitting strings validators urls
 html.elements
 html.components
-html.templates.chloe
+furnace.boilerplate
-http.server.boilerplate
+furnace.auth.providers
-http.server.auth.providers
+furnace.auth.providers.db
-http.server.auth.providers.db
+furnace.auth.login
-http.server.auth.login
+furnace.auth
-http.server.auth
+furnace.sessions
-http.server.sessions
+furnace.actions
-http.server.actions
 http.server ;
 IN: webapps.user-admin
 
-: admin-template ( name -- template )
+: word>string ( word -- string )
-    "resource:extra/webapps/user-admin/" swap ".xml" 3append <chloe> ;
+    [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
 
 : words>strings ( seq -- seq' )
-    [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
+    [ word>string ] map ;
+
+: string>word ( string -- word )
+    ":" split1 swap lookup ;
 
 : strings>words ( seq -- seq' )
-    [ ":" split1 swap lookup ] map ;
+    [ string>word ] map ;
 
 : <user-list-action> ( -- action )
     <page-action>
         [ f <user> select-tuples "users" set-value ] >>init
-        "user-list" admin-template >>template ;
+        "$user-admin/user-list" >>template ;
+
+: init-capabilities ( -- )
+    capabilities get words>strings "capabilities" set-value ;
+
+: selected-capabilities ( -- seq )
+    "capabilities" value
+    [ param empty? not ] filter
+    [ string>word ] map ;
 
 : <new-user-action> ( -- action )
     <page-action>
         [
-            "username" param <user> from-tuple
+            "username" param <user> from-object
-            capabilities get words>strings "all-capabilities" set-value
+            init-capabilities
         ] >>init
 
-        "new-user" admin-template >>template
+        "$user-admin/new-user" >>template
 
         [
-            capabilities get words>strings "all-capabilities" set-value
+            init-capabilities
 
             {
                 { "username" [ v-username ] }
@@ -62,10 +72,11 @@ IN: webapps.user-admin
                 "email" value >>email
                 "new-password" value >>encoded-password
                 H{ } clone >>profile
+                selected-capabilities >>capabilities
 
             insert-tuple
 
-            "$user-admin" f <standard-redirect>
+            URL" $user-admin" <redirect>
         ] >>submit ;
 
 : validate-username ( -- )
@@ -77,15 +88,16 @@ IN: webapps.user-admin
             validate-username
 
             "username" value <user> select-tuple
-            [ from-tuple ] [ capabilities>> words>strings "capabilities" set-value ] bi
+            [ from-object ]
+            [ capabilities>> [ "true" swap word>string set-value ] each ] bi
 
-            capabilities get words>strings "all-capabilities" set-value
+            capabilities get words>strings "capabilities" set-value
         ] >>init
 
-        "edit-user" admin-template >>template
+        "$user-admin/edit-user" >>template
 
         [
-            capabilities get words>strings "all-capabilities" set-value
+            init-capabilities
 
             {
                 { "username" [ v-username ] }
@@ -93,7 +105,6 @@ IN: webapps.user-admin
                 { "new-password" [ [ v-password ] v-optional ] }
                 { "verify-password" [ [ v-password ] v-optional ] }
                 { "email" [ [ v-email ] v-optional ] }
-                { "capabilities" [ ] }
             } validate-params
 
             "new-password" "verify-password"
@@ -106,19 +117,15 @@ IN: webapps.user-admin
             "username" value <user> select-tuple
                 "realname" value >>realname
                 "email" value >>email
+                selected-capabilities >>capabilities
 
             "new-password" value empty? [
                 "new-password" value >>encoded-password
             ] unless
 
-            "capabilities" value {
-                { [ dup string? ] [ 1array ] }
-                { [ dup array? ] [ ] }
-            } cond strings>words >>capabilities
-
             update-tuple
 
-            "$user-admin" f <standard-redirect>
+            URL" $user-admin" <redirect>
         ] >>submit ;
 
 : <delete-user-action> ( -- action )
@@ -130,7 +137,7 @@ IN: webapps.user-admin
             [ logout-all-sessions ]
             bi
 
-            "$user-admin" f <standard-redirect>
+            URL" $user-admin" <redirect>
         ] >>submit ;
 
 TUPLE: user-admin < dispatcher ;
@@ -146,7 +153,7 @@ can-administer-users? define-capability
         <edit-user-action> "edit" add-responder
         <delete-user-action> "delete" add-responder
     <boilerplate>
-        "user-admin" admin-template >>template
+        "$user-admin/user-admin" >>template
     { can-administer-users? } <protected> ;
 
 : make-admin ( username -- )

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

@@ -6,13 +6,13 @@
 
 	<ul>
 
-		<t:each-tuple t:values="users">
+		<t:bind-each t:name="users">
 			<li>
 				<t:a t:href="$user-admin/edit" t:query="username">
 					<t:label t:name="username" />
 				</t:a>
 			</li>
-		</t:each-tuple>
+		</t:bind-each>
 
 	</ul>
 

extra/webapps/wiki/articles.xml

@@ -5,11 +5,11 @@
 	<t:title>All Articles</t:title>
 
 	<ul>
-		<t:each-tuple t:values="articles">
+		<t:bind-each t:name="articles">
 			<li>
 				<t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
 			</li>
-		</t:each-tuple>
+		</t:bind-each>
 	</ul>
 
 </t:chloe>

extra/webapps/wiki/changes.xml

@@ -5,7 +5,7 @@
 	<t:title>Recent Changes</t:title>
 
 	<ul>
-		<t:each-tuple t:values="changes">
+		<t:bind-each t:name="changes">
 			<li>
 				<t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a>
 				on
@@ -13,7 +13,7 @@
 				by
 				<t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
 			</li>
-		</t:each-tuple>
+		</t:bind-each>
 	</ul>
 
 </t:chloe>

extra/webapps/wiki/diff.xml

@@ -2,34 +2,34 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:bind-tuple t:name="old">
+	<t:bind t:name="old">
 		<t:title>Diff: <t:label t:name="title" /></t:title>
-	</t:bind-tuple>
+	</t:bind>
 
 	<table>
 		<tr>
 			<th class="field-label">Old revision:</th>
-			<t:bind-tuple t:name="old">
+			<t:bind t:name="old">
 				<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
-			</t:bind-tuple>
+			</t:bind>
 		</tr>
 		<tr>
 			<th class="field-label">New revision:</th>
-			<t:bind-tuple t:name="old">
+			<t:bind t:name="old">
 				<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
-			</t:bind-tuple>
+			</t:bind>
 		</tr>
 	</table>
 
 	<t:comparison t:name="diff" />
 
-	<t:bind-tuple t:name="old">
+	<t:bind t:name="old">
 		<div class="navbar">
 			<t:a t:href="$wiki/view" t:query="title">Latest</t:a>
 			| <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
 			| <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
 			| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
 		</div>
-	</t:bind-tuple>
+	</t:bind>
 
 </t:chloe>

extra/webapps/wiki/revisions.xml

@@ -4,15 +4,23 @@
 
 	<t:title>Revisions of <t:label t:name="title" /></t:title>
 
-	<ul>
+	<div class="revisions">
-		<t:each-tuple t:values="revisions">
+		<table>
-			<li>
+			<tr>
-				<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
+				<th>Revision</th>
-				by
+				<th>Author</th>
-				<t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
+				<th>Rollback</th>
-			</li>
+			</tr>
-		</t:each-tuple>
+
-	</ul>
+			<t:bind-each t:name="revisions">
+				<tr>
+					<td> <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> </td>
+					<td> <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> </td>
+					<td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
+				</tr>
+			</t:bind-each>
+		</table>
+	</div>
 
 	<h2>View Differences</h2>
 
@@ -23,9 +31,9 @@
 				
 				<td>
 					<select name="old-id">
-						<t:each-tuple t:values="revisions">
+						<t:bind-each t:name="revisions">
 							<option> <t:label t:name="id" /> </option>
-						</t:each-tuple>
+						</t:bind-each>
 					</select>
 				</td>
 			</tr>
@@ -34,9 +42,9 @@
 				
 				<td>
 					<select name="new-id">
-						<t:each-tuple t:values="revisions">
+						<t:bind-each t:name="revisions">
 							<option> <t:label t:name="id" /> </option>
-						</t:each-tuple>
+						</t:bind-each>
 					</select>
 				</td>
 			</tr>
@@ -45,4 +53,13 @@
 		<input type="submit" value="View" />
 	</form>
 
+	<br/>
+
+	<div class="navbar">
+		<t:a t:href="$wiki/view" t:query="title">Latest</t:a>
+		| <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
+		| <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
+		| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
+	</div>
+
 </t:chloe>

extra/webapps/wiki/user-edits.xml

@@ -5,13 +5,13 @@
 	<t:title>Edits by <t:label t:name="author" /></t:title>
 
 	<ul>
-		<t:each-tuple t:values="user-edits">
+		<t:bind-each t:name="user-edits">
 			<li>
 				<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>
 			</li>
-		</t:each-tuple>
+		</t:bind-each>
 	</ul>
 
 </t:chloe>

extra/webapps/wiki/wiki.css

@@ -1,8 +1,3 @@
-.comparison table, {
-    border-color: #666;
-    border-style: solid;
-}
-
 .comparison th {
     border-width: 1px;
     border-color: #666;
@@ -10,12 +5,13 @@
 }
 
 .comparison table {
+    border-color: #666;
+    border-style: solid;
     border-width: 1px;
     border-spacing: 0;
     border-collapse: collapse;
 }
 
-
 .insert {
     background-color: #9f9;
 }
@@ -23,3 +19,21 @@
 .delete {
     background-color: #f99;
 }
+
+.revisions table, .revisions td, .revisions th {
+    border-color: #666;
+    border-style: solid;
+}
+
+.revisions table {
+    border-width: 0 0 1px 1px;
+    border-spacing: 0;
+    border-collapse: collapse;
+}
+
+.revisions td, .revisions th {
+    margin: 0;
+    padding: 4px;
+    border-width: 1px 1px 0 0;
+}
+

extra/webapps/wiki/wiki.factor

@@ -3,14 +3,13 @@
 USING: accessors kernel hashtables calendar
 namespaces splitting sequences sorting math.order
 html.components
-html.templates.chloe
 http.server
-http.server.actions
+furnace.actions
-http.server.auth
+furnace.auth
-http.server.auth.login
+furnace.auth.login
-http.server.boilerplate
+furnace.boilerplate
 validators
-db.types db.tuples lcs farkup ;
+db.types db.tuples lcs farkup urls ;
 IN: webapps.wiki
 
 TUPLE: article title revision ;
@@ -41,18 +40,17 @@ revision "REVISIONS" {
 
 : init-revisions-table revision ensure-table ;
 
-: wiki-template ( name -- template )
-    "resource:extra/webapps/wiki/" swap ".xml" 3append <chloe> ;
-
-: <title-redirect> ( title next -- response )
-    swap "title" associate <standard-redirect> ;
-
 : validate-title ( -- )
     { { "title" [ v-one-line ] } } validate-params ;
 
 : <main-article-action> ( -- action )
     <action>
-        [ "Front Page" "$wiki/view" <title-redirect> ] >>display ;
+        [
+            <url>
+                "$wiki/view" >>path
+                "Front Page" "title" set-query-param
+            <redirect>
+        ] >>display ;
 
 : <view-article-action> ( -- action )
     <action>
@@ -65,10 +63,13 @@ revision "REVISIONS" {
 
         [
             "title" value dup <article> select-tuple [
-                revision>> <revision> select-tuple from-tuple
+                revision>> <revision> select-tuple from-object
-                "view" wiki-template <html-content>
+                "$wiki/view" <chloe-content>
             ] [
-                "$wiki/edit" <title-redirect>
+                <url>
+                    "$wiki/edit" >>path
+                    swap "title" set-query-param
+                <redirect>
             ] ?if
         ] >>display ;
 
@@ -77,10 +78,10 @@ revision "REVISIONS" {
         [
             { { "id" [ v-integer ] } } validate-params
             "id" value <revision>
-            select-tuple from-tuple
+            select-tuple from-object
         ] >>init
 
-        "view" wiki-template >>template ;
+        "$wiki/view" >>template ;
 
 : add-revision ( revision -- )
     [ insert-tuple ]
@@ -97,11 +98,11 @@ revision "REVISIONS" {
         [
             validate-title
             "title" value <article> select-tuple [
-                revision>> <revision> select-tuple from-tuple
+                revision>> <revision> select-tuple from-object
             ] when*
         ] >>init
 
-        "edit" wiki-template >>template
+        "$wiki/edit" >>template
         
         [
             validate-title
@@ -113,7 +114,12 @@ revision "REVISIONS" {
                 logged-in-user get username>> >>author
                 "content" value >>content
             [ add-revision ]
-            [ title>> "$wiki/view" <title-redirect> ] bi
+            [
+                <url>
+                    "$wiki/view" >>path
+                    swap title>> "title" set-query-param
+                <redirect>
+            ] bi
         ] >>submit ;
 
 : <list-revisions-action> ( -- action )
@@ -125,7 +131,24 @@ revision "REVISIONS" {
             "revisions" set-value
         ] >>init
 
-        "revisions" wiki-template >>template ;
+        "$wiki/revisions" >>template ;
+
+: <rollback-action> ( -- action )
+    <action>
+        [
+            { { "id" [ v-integer ] } } validate-params
+        ] >>validate
+        
+        [
+            "id" value <revision> select-tuple clone f >>id
+            [ add-revision ]
+            [
+                <url>
+                    "$wiki/view" >>path
+                    swap title>> "title" set-query-param
+                <redirect>
+            ] bi
+        ] >>submit ;
 
 : <list-changes-action> ( -- action )
     <page-action>
@@ -135,7 +158,7 @@ revision "REVISIONS" {
             "changes" set-value
         ] >>init
 
-        "changes" wiki-template >>template ;
+        "$wiki/changes" >>template ;
 
 : <delete-action> ( -- action )
     <action>
@@ -144,7 +167,7 @@ revision "REVISIONS" {
         [
             "title" value <article> delete-tuples
             f <revision> "title" value >>title delete-tuples
-            "" f <standard-redirect>
+            URL" $wiki" <redirect>
         ] >>submit ;
 
 : <diff-action> ( -- action )
@@ -162,7 +185,7 @@ revision "REVISIONS" {
             2bi
         ] >>init
 
-        "diff" wiki-template >>template ;
+        "$wiki/diff" >>template ;
 
 : <list-articles-action> ( -- action )
     <page-action>
@@ -172,7 +195,7 @@ revision "REVISIONS" {
             "articles" set-value
         ] >>init
 
-        "articles" wiki-template >>template ;
+        "$wiki/articles" >>template ;
 
 : <user-edits-action> ( -- action )
     <page-action>
@@ -182,7 +205,7 @@ revision "REVISIONS" {
             select-tuples "user-edits" set-value
         ] >>init
 
-        "user-edits" wiki-template >>template ;
+        "$wiki/user-edits" >>template ;
 
 TUPLE: wiki < dispatcher ;
 
@@ -192,6 +215,7 @@ TUPLE: wiki < dispatcher ;
         <view-article-action> "view" add-responder
         <view-revision-action> "revision" add-responder
         <list-revisions-action> "revisions" add-responder
+        <rollback-action> "rollback" add-responder
         <user-edits-action> "user-edits" add-responder
         <diff-action> "diff" add-responder
         <list-articles-action> "articles" add-responder
@@ -199,4 +223,4 @@ TUPLE: wiki < dispatcher ;
         <edit-article-action> { } <protected> "edit" add-responder
         <delete-action> { } <protected> "delete" add-responder
     <boilerplate>
-        "wiki-common" wiki-template >>template ;
+        "$wiki/wiki-common" >>template ;

extra/xmode/code2html/code2html.factor

@@ -1,14 +1,14 @@
 USING: xmode.tokens xmode.marker xmode.catalog kernel
 html.elements io io.files sequences words io.encodings.utf8
-namespaces xml.entities ;
+namespaces xml.entities accessors ;
 IN: xmode.code2html
 
 : htmlize-tokens ( tokens -- )
     [
-        dup token-str swap token-id [
+        [ str>> ] [ id>> ] bi [
             <span word-name =class span> escape-string write </span>
         ] [
-            write
+            escape-string write
         ] if*
     ] each ;
 

extra/xmode/code2html/responder/responder.factor

@@ -12,5 +12,5 @@ IN: xmode.code2html.responder
             , utf8 [
                 , file-name input-stream get htmlize-stream
             ] with-file-reader
-        ] <html-content>
+        ] "text/html" <content>
     ] <file-responder> ;