Merge branch 'master' of git://factorcode.org/git/factor

core/io/files/files.factor

@@ -147,6 +147,9 @@ PRIVATE>
         ] if
     ] unless ;
 
+: file-extension ( filename -- extension )
+    "." last-split1 nip ;
+
 ! File info
 TUPLE: file-info type size permissions modified ;
 

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

@@ -1,9 +1,17 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences kernel assocs combinators http.server
+USING: accessors sequences kernel assocs combinators
 validators http hashtables namespaces fry continuations locals
-boxes xml.entities html.elements html.components io arrays math ;
+io arrays math boxes
-IN: http.server.actions
+xml.entities
+http.server
+http.server.responses
+furnace
+html.elements
+html.components
+html.templates.chloe
+html.templates.chloe.syntax ;
+IN: furnace.actions
 
 SYMBOL: params
 
@@ -17,6 +25,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 +85,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 +93,9 @@ 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
-        dup '[ , feed>> call <feed-content> ] >>display ;

extra/furnace/auth/auth.factor

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

extra/furnace/auth/basic/basic.factor

@@ -1,10 +1,10 @@
 ! Copyright (c) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors quotations assocs kernel splitting
-base64 html.elements io combinators http.server
+base64 html.elements io combinators sequences
-http.server.auth.providers http.server.auth.login
+http http.server.filters http.server.responses http.server
-http sequences ;
+furnace.auth.providers furnace.auth.login ;
-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,22 @@ checksums.sha2
 validators
 html.components
 html.elements
-html.templates
+urls
-html.templates.chloe
 http
 http.server
-http.server.auth
+http.server.dispatchers
-http.server.auth.providers
+http.server.filters
-http.server.auth.providers.db
+http.server.responses
-http.server.actions
+furnace
-http.server.flows
+furnace.auth
-http.server.sessions
+furnace.auth.providers
-http.server.boilerplate ;
+furnace.auth.providers.db
+furnace.actions
+furnace.flows
+furnace.sessions
+furnace.boilerplate ;
 QUALIFIED: smtp
-IN: http.server.auth.login
+IN: furnace.auth.login
 
 TUPLE: login < dispatcher users checksum ;
 
@@ -59,21 +62,17 @@ 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 ;
+    username>> set-uid URL" $login" end-flow ;
 
 : login-failed ( -- * )
     "invalid username or password" validation-error
     validation-failed ;
 
 : <login-action> ( -- action )
-    <action>
+    <page-action>
-        [ "login" login-template <html-content> ] >>display
+        { login "login" } >>template
 
         [
             {
@@ -102,7 +101,7 @@ M: user-saver dispose
 
 : <register-action> ( -- action )
     <page-action>
-        "register" login-template >>template
+        { login "register" } >>template
 
         [
             {
@@ -134,7 +133,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 +142,7 @@ M: user-saver dispose
             tri
         ] >>init
 
-        [ "edit-profile" login-template <html-content> ] >>display
+        { login "edit-profile" } >>template
 
         [
             uid "username" set-value
@@ -178,7 +177,7 @@ M: user-saver dispose
 
             drop
 
-            "$login" end-flow
+            URL" $login" end-flow
         ] >>submit ;
 
 ! ! ! Password recovery
@@ -186,10 +185,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 +222,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 +239,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 +255,7 @@ SYMBOL: lost-password-from
             } validate-params
         ] >>init
 
-        [ "recover-3" login-template <html-content> ] >>display
+        { login "recover-3" } >>template
 
         [
             {
@@ -272,18 +275,22 @@ SYMBOL: lost-password-from
                 "new-password" value >>encoded-password
                 users update-user
 
-                "recover-4" login-template <html-content>
+                URL" $login/recover-4" <redirect>
             ] [
-                <400>
+                <403>
             ] if*
         ] >>submit ;
 
+: <recover-action-4> ( -- action )
+    <page-action>
+        { login "recover-4" } >>template ;
+
 ! ! ! Logout
 : <logout-action> ( -- action )
     <action>
         [
             f set-uid
-            "$login/login" end-flow
+            URL" $login" end-flow
         ] >>submit ;
 
 ! ! ! Authentication logic
@@ -294,7 +301,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 +324,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 +347,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/login/login.xml

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

extra/furnace/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,12 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces http.server html.templates
+USING: accessors kernel namespaces
-locals ;
+html.templates html.templates.chloe
-IN: http.server.boilerplate
+locals
+http.server
+http.server.filters
+furnace ;
+IN: furnace.boilerplate
 
 TUPLE: boilerplate < filter-responder template ;
 
@@ -12,6 +16,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/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,9 @@
 ! 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: kernel accessors continuations namespaces destructors
-kernel accessors continuations namespaces destructors ;
+db db.pools io.pools http.server http.server.filters
-IN: http.server.db
+furnace.sessions ;
+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 ;
+furnace http http.server http.server.filters furnace.sessions
-IN: http.server.flows
+html.elements 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-tests.factor

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

extra/furnace/furnace.factor

@@ -0,0 +1,183 @@
+! Copyright (C) 2003, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel combinators assocs
+continuations namespaces sequences splitting words
+vocabs.loader classes
+fry urls multiline
+xml
+xml.data
+xml.writer
+xml.utilities
+html.components
+html.elements
+html.templates
+html.templates.chloe
+html.templates.chloe.syntax
+http
+http.server
+http.server.redirection
+http.server.responses
+qualified ;
+QUALIFIED-WITH: assocs a
+IN: furnace
+
+: nested-responders ( -- seq )
+    responder-nesting get a:values ;
+
+: each-responder ( quot -- )
+   nested-responders swap each ; inline
+
+: base-path ( string -- pair )
+    dup responder-nesting get
+    [ second class word-name = ] with find nip
+    [ first ] [ "No such responder: " swap append throw ] ?if ;
+
+: resolve-base-path ( string -- string' )
+    "$" ?head [
+        [
+            "/" split1 [ base-path [  "/" % % ] each "/" % ] dip %
+        ] "" make
+    ] when ;
+
+: vocab-path ( vocab -- path )
+    dup vocab-dir vocab-append-path ;
+
+: resolve-template-path ( pair -- path )
+    [
+        first2 [ word-vocabulary vocab-path % ] [ "/" % % ] bi*
+    ] "" make ;
+
+GENERIC: modify-query ( query responder -- query' )
+
+M: object modify-query drop ;
+
+: adjust-url ( url -- url' )
+    clone
+        [ [ modify-query ] each-responder ] change-query
+        [ resolve-base-path ] change-path
+    relative-to-request ;
+
+: <redirect> ( url -- response )
+    adjust-url request get method>> {
+        { "GET" [ <temporary-redirect> ] }
+        { "HEAD" [ <temporary-redirect> ] }
+        { "POST" [ <permanent-redirect> ] }
+    } case ;
+
+GENERIC: hidden-form-field ( responder -- )
+
+M: object hidden-form-field drop ;
+
+: request-params ( request -- assoc )
+    dup method>> {
+        { "GET" [ url>> query>> ] }
+        { "HEAD" [ url>> query>> ] }
+        { "POST" [ post-data>> ] }
+    } case ;
+
+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 relative-to-request
+    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 relative-to-request =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 ;
+
+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 -- ? )
+    "code" required-attr attr>word execute ;
+
+CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;

extra/furnace/json/json.factor

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

extra/furnace/rss/rss.factor

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

extra/furnace/sessions/sessions-tests.factor

@@ -1,8 +1,10 @@
-IN: 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 http.server.responses
+math namespaces kernel accessors
 prettyprint io.streams.string io.files splitting destructors
-sequences db db.sqlite continuations ;
+sequences db db.sqlite continuations urls math.parser
+furnace ;
 
 : with-session
     [
@@ -18,15 +20,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
+            dup url>>
                 "id" get session-id-key set-query-param
-            "/" >>path
+                "/" >>path drop
-        request set
+        init-request
         { } sessions get call-responder
         [ write-response-body drop ] with-string-writer
     ] with-destructors ;
@@ -36,21 +39,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
 
     [ ] [
@@ -113,7 +116,7 @@ M: foo call-responder*
     [
         <request>
             "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 +134,9 @@ M: foo call-responder*
         [ ] [
             <request>
                 "GET" >>method
+                dup url>>
                     "id" get session-id-key set-query-param
-                "/" >>path
+                    "/" >>path drop
             request set
 
             [

extra/furnace/sessions/sessions.factor

@@ -4,8 +4,9 @@ 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 http.server.dispatchers http.server.filters
-IN: http.server.sessions
+html.elements furnace ;
+IN: furnace.sessions
 
 TUPLE: session id expires uid namespace changed? ;
 
@@ -136,7 +137,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,7 +146,6 @@ 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 ;

extra/html/components/components-tests.factor

@@ -1,7 +1,7 @@
 IN: html.components.tests
 USING: tools.test kernel io.streams.string
 io.streams.null accessors inspector html.streams
-html.components namespaces ;
+html.elements html.components namespaces ;
 
 [ ] [ blank-values ] unit-test
 
@@ -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
 
 >>
@@ -178,7 +190,7 @@ SYMBOL: html
     <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
         <head> <title> swap write </title> </head>
         <body> call </body>
-    </html> ;
+    </html> ; inline
 
 : render-error ( message -- )
     <span "error" =class span> escape-string write </span> ;

extra/html/parser/analyzer/analyzer.factor

@@ -1,6 +1,6 @@
 USING: assocs html.parser kernel math sequences strings ascii
 arrays shuffle unicode.case namespaces splitting http
-sequences.lib accessors io combinators http.client ;
+sequences.lib accessors io combinators http.client urls ;
 IN: html.parser.analyzer
 
 TUPLE: link attributes clickable ;

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

@@ -1,7 +1,7 @@
 USING: html.templates html.templates.chloe
 tools.test io.streams.string kernel sequences ascii boxes
 namespaces xml html.components
-splitting unicode.categories ;
+splitting unicode.categories furnace ;
 IN: html.templates.chloe.tests
 
 [ f ] [ f parse-query-attr ] unit-test
@@ -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" ] [
     [
@@ -70,24 +69,6 @@ IN: html.templates.chloe.tests
     ] run-template
 ] unit-test
 
-SYMBOL: test6-aux?
-
-[ "True" ] [
-    [
-        test6-aux? on
-        "test6" test-template call-template
-    ] run-template
-] unit-test
-
-SYMBOL: test7-aux?
-
-[ "" ] [
-    [
-        test7-aux? off
-        "test7" test-template call-template
-    ] run-template
-] unit-test
-
 [ ] [ blank-values ] unit-test
 
 [ ] [ "A label" "label" set-value ] unit-test
@@ -128,7 +109,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
 
 [ "<ul><li>1</li><li>2</li><li>3</li></ul>" ] [
     [
-        "test9" test-template call-template
+        "test7" test-template call-template
     ] run-template [ blank? not ] filter
 ] unit-test
 
@@ -143,7 +124,7 @@ TUPLE: person first-name last-name ;
 
 [ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
     [
-        "test10" test-template call-template
+        "test8" test-template call-template
     ] run-template [ blank? not ] filter
 ] unit-test
 
@@ -156,6 +137,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
+        "test8" test-template call-template
     ] run-template [ blank? not ] filter
 ] unit-test
+
+[ ] [ 1 "id" set-value ] unit-test
+
+[ "<a name=\"1\">Hello</a>" ] [
+    [
+        "test9" test-template call-template
+    ] run-template
+] unit-test

extra/html/templates/chloe/chloe.factor

@@ -3,19 +3,16 @@
 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
+SYMBOL: tag-stack
 
 TUPLE: chloe path ;
 
@@ -23,8 +20,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 +33,23 @@ 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
+    "head" tag-stack get member?
+    "title" tag-stack 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 +59,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,94 +72,56 @@ 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: textarea
-    [ new [ attrs>slots ] keep ]
+CHLOE-TUPLE: password
-    2bi render ;
+CHLOE-TUPLE: choice
+CHLOE-TUPLE: checkbox
+CHLOE-TUPLE: code
 
 : process-chloe-tag ( tag -- )
-    dup name-tag {
+    dup name-tag dup 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 -- )
     {
-        [ name-tag >lower tags get push ]
+        [ name-tag >lower tag-stack get push ]
         [ write-start-tag ]
         [ process-tag-children ]
         [ write-end-tag ]
-        [ drop tags get pop* ]
+        [ drop tag-stack get pop* ]
     } cleave ;
 
+: expand-attrs ( tag -- tag )
+    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 ] }
@@ -319,7 +130,7 @@ STRING: button-tag-markup
 
 : process-chloe ( xml -- )
     [
-        V{ } clone tags set
+        V{ } clone tag-stack set
 
         nested-template? get [
             process-template
@@ -334,6 +145,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,61 @@
+! 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 -- ) swap tags get set-at ;
+
+: CHLOE:
+    scan parse-definition 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-word
+    [ word-name ] [ '[ , singleton-component-tag ] ] bi
+    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-word
+    [ word-name ] [ '[ , tuple-component-tag ] ] bi
+    define-chloe-tag ;
+    parsing

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

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

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

@@ -1,14 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-	<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/test6.xml

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

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

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

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

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

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

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

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,36 +10,26 @@ tuple-syntax namespaces ;
 
 [
     TUPLE{ request
-        protocol: http
+        url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" }
         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" } }
     }
 ] [
-    [
     "http://www.apple.com/index.html"
     <get-request>
-    ] with-scope
 ] unit-test
 
 [
     TUPLE{ request
-        protocol: https
+        url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" }
         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" } }
     }
 ] [
-    [
     "https://www.amazon.com/index.html"
     <get-request>
-    ] with-scope
 ] unit-test

extra/http/client/client.factor

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

extra/http/http-tests.factor

@@ -1,37 +1,8 @@
 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 +16,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 +53,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 +65,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 +118,16 @@ 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 ;
+accessors namespaces threads
+http.server.responses http.server.redirection
+http.server.dispatchers ;
 
 : 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 +146,7 @@ test-db [
                 "resource:extra/http/test" <static> >>default
             "nested" add-responder
             <action>
-                [ "redirect-loop" f <standard-redirect> ] >>display
+                [ URL" redirect-loop" <temporary-redirect> ] >>display
             "redirect-loop" add-responder
         main-responder set
 
@@ -186,16 +161,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 +202,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

@@ -6,90 +6,16 @@ assocs sequences splitting sorting sets debugger
 strings vectors hashtables quotations arrays byte-arrays
 math.parser calendar calendar.format
 
-io io.streams.string io.encodings.utf8 io.encodings.string
+io io.server io.sockets.secure
-io.sockets io.sockets.secure
 
 unicode.case unicode.categories qualified
 
-html.templates ;
+urls html.templates ;
 
 EXCLUDE: fry => , ;
 
 IN: http
 
-SINGLETON: http
-
-SINGLETON: https
-
-GENERIC: http-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 ] }
-        { "https" [ https ] }
-        [ "Unknown protocol: " swap append throw ]
-    } case ;
-
-: absolute-url? ( url -- ? )
-    [ "http://" head? ] [ "https://" head? ] bi or ;
-
-: 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 ;
 
 : add-header ( value key assoc -- )
@@ -130,6 +56,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 +72,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 +127,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,51 +141,30 @@ cookies ;
 : <request>
     request new
         "1.1" >>version
-        http >>protocol
+        <url>
-        H{ } clone >>header
+            "http" >>protocol
             H{ } clone >>query
+        >>url
+        H{ } clone >>header
         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
-    dup empty? [ drop "/" ] when ;
-
-: url>path ( url -- path )
-    #! Technically, only proxies are meant to support hostnames
-    #! in HTTP requests, but IE sends these sometimes so we
-    #! just chop the hostname part.
-    url-decode
-    dup { "http://" "https://" } [ head? ] with contains?
-    [ chop-hostname ] when ;
-
 : read-method ( request -- request )
     " " read-until [ "Bad request: method" throw ] unless
     >>method ;
 
-: 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 +191,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 +213,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 +223,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 +232,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 +244,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,39 +269,6 @@ 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
-    [ 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 -- )
 
 GENERIC: write-full-response ( request response -- )

extra/http/mime/mime.factor

@@ -1,35 +0,0 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io assocs kernel sequences math namespaces splitting ;
-
-IN: http.mime
-
-: file-extension ( filename -- extension )
-    "." split dup length 1 <= [ drop f ] [ peek ] if ;
-
-: mime-type ( filename -- mime-type )
-    file-extension "mime-types" get at "application/octet-stream" or ;
-
-H{
-    { "html"   "text/html"                        }
-    { "txt"    "text/plain"                       }
-    { "xml"    "text/xml"                         }
-    { "css"    "text/css"                         }
-                                                    
-    { "gif"    "image/gif"                        }
-    { "png"    "image/png"                        }
-    { "jpg"    "image/jpeg"                       }
-    { "jpeg"   "image/jpeg"                       }
-                                                    
-    { "jar"    "application/octet-stream"         }
-    { "zip"    "application/octet-stream"         }
-    { "tgz"    "application/octet-stream"         }
-    { "tar.gz" "application/octet-stream"         }
-    { "gz"     "application/octet-stream"         }
-
-    { "pdf"    "application/pdf"                  }
-
-    { "factor" "text/plain"                       }
-    { "cgi"    "application/x-cgi-script"         }
-    { "fhtml"  "application/x-factor-server-page" }
-} "mime-types" set-global

extra/http/server/cgi/cgi.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel assocs io.files io.streams.duplex
 combinators arrays io.launcher io http.server.static http.server
-http accessors sequences strings math.parser fry ;
+http accessors sequences strings math.parser fry urls ;
 IN: http.server.cgi
 
 : post? request get method>> "POST" = ;
@@ -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
@@ -29,7 +28,7 @@ IN: http.server.cgi
         "" "REMOTE_IDENT" set
 
         request get method>> "REQUEST_METHOD" set
-        request get query>> assoc>query "QUERY_STRING" set
+        request get url>> query>> assoc>query "QUERY_STRING" set
         request get "cookie" header "HTTP_COOKIE" set 
 
         request get "user-agent" header "HTTP_USER_AGENT" 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/dispatchers/dispatchers-tests.factor

@@ -1,28 +1,10 @@
-USING: http.server tools.test kernel namespaces accessors
+USING: http.server http.server.dispatchers http.server.responses
-io http math sequences assocs arrays classes words ;
+tools.test kernel namespaces accessors io http math sequences
-IN: http.server.tests
+assocs arrays classes words urls ;
+IN: http.server.dispatchers.tests
 
 \ find-responder must-infer
-
+\ http-error. must-infer
-[
-    <request>
-    http >>protocol
-    "www.apple.com" >>host
-    "/xxx/bar" >>path
-    { { "a" "b" } } >>query
-    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/baz?a=b" ] [ "baz" f derive-url ] unit-test
-    [ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] 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/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test
-    [ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test
-    [ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] unit-test
-] with-scope
 
 TUPLE: mock-responder path ;
 
@@ -31,10 +13,10 @@ 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
+    V{ } clone responder-nesting set
     over off
     split-path
     main-responder get call-responder
@@ -84,10 +66,10 @@ 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
+    V{ } clone responder-nesting set
 
     { "b" "c" }
     <dispatcher>
@@ -113,30 +95,3 @@ M: path-check-responder call-responder*
     [ t ] [ "bar" "bar" check-dispatch ] unit-test
     [ t ] [ "baz" "xxx" check-dispatch ] unit-test
 ] unit-test
-
-TUPLE: funny-dispatcher < dispatcher ;
-
-: <funny-dispatcher> funny-dispatcher new-dispatcher ;
-
-TUPLE: base-path-check-responder ;
-
-C: <base-path-check-responder> base-path-check-responder
-
-M: base-path-check-responder call-responder*
-    2drop
-    "$funny-dispatcher" resolve-base-path
-    <text-content> ;
-
-[ ] [
-    <dispatcher>
-        <dispatcher>
-            <funny-dispatcher>
-                <base-path-check-responder> "c" add-responder
-            "b" add-responder
-        "a" add-responder
-    main-responder set
-] unit-test
-
-[ "/a/b/" ] [
-    "a/b/c" split-path main-responder get call-responder body>>
-] unit-test

extra/http/server/dispatchers/dispatchers.factor

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

extra/http/server/filters/filters.factor

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

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

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

extra/http/server/redirection/redirection.factor

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

extra/http/server/responses/responses.factor

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

extra/http/server/server.factor

@@ -1,276 +1,74 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel namespaces io io.timeouts strings splitting
+USING: kernel accessors sequences arrays namespaces splitting
-threads sequences prettyprint io.server logging calendar http
+vocabs.loader http http.server.responses logging calendar
-html.streams html.elements accessors math.parser
+destructors html.elements html.streams io.server
-combinators.lib tools.vocabs debugger continuations random
+io.encodings.8-bit io.timeouts io assocs debugger continuations
-combinators destructors io.encodings.8-bit fry classes words
+fry tools.vocabs math ;
-math rss json.writer ;
 IN: http.server
 
+SYMBOL: responder-nesting
+
+SYMBOL: main-responder
+
+SYMBOL: development-mode
+
 ! path is a sequence of path component strings
-
 GENERIC: call-responder* ( path responder -- response )
 
-: request-params ( request -- assoc )
-    dup method>> {
-        { "GET" [ query>> ] }
-        { "HEAD" [ query>> ] }
-        { "POST" [ post-data>> ] }
-    } case ;
-
-: <content> ( body content-type -- response )
-    <response>
-        200 >>code
-        "Document follows" >>message
-        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
 
-M: trivial-responder call-responder* nip response>> call ;
+M: trivial-responder call-responder* nip response>> clone ;
 
-: trivial-response-body ( code message -- )
+main-responder global [ <404> <trivial-responder> get-global or ] change-at
-    <html>
-        <body>
-            <h1> [ number>string write bl ] [ write ] bi* </h1>
-        </body>
-    </html> ;
-
-: <trivial-response> ( code message -- response )
-    2dup '[ , , trivial-response-body ] <html-content>
-        swap >>message
-        swap >>code ;
-
-: <400> ( -- response )
-    400 "Bad request" <trivial-response> ;
-
-: <404> ( -- response )
-    404 "Not Found" <trivial-response> ;
-
-SYMBOL: 404-responder
-
-[ <404> ] <trivial-responder> 404-responder set-global
-
-SYMBOL: base-paths
 
 : invert-slice ( slice -- slice' )
-    dup slice? [
+    dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
-        [ seq>> ] [ from>> ] bi head-slice
-    ] [
-        drop { }
-    ] if ;
 
-: add-base-path ( path dispatcher -- )
+: add-responder-nesting ( path responder -- )
-    [ invert-slice ] [ class word-name ] bi*
+    [ invert-slice ] dip 2array responder-nesting get push ;
-    base-paths get set-at ;
 
 : call-responder ( path responder -- response )
-    [ add-base-path ] [ call-responder* ] 2bi ;
+    [ add-responder-nesting ] [ call-responder* ] 2bi ;
-
-SYMBOL: link-hook
-
-: add-link-hook ( quot -- )
-    link-hook [ compose ] change ; inline
-
-: modify-query ( query -- query )
-    link-hook get call ;
-
-: base-path ( string -- path )
-    dup base-paths get at
-    [ ] [ "No such responder: " swap append throw ] ?if ;
-
-: resolve-base-path ( string -- string' )
-    "$" ?head [
-        [
-            "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
-        ] "" make
-    ] when ;
-
-: link>string ( url query -- url' )
-    [ resolve-base-path ] [ modify-query ] bi* (link>string) ;
-
-: write-link ( url query -- )
-    link>string write ;
-
-SYMBOL: form-hook
-
-: add-form-hook ( quot -- )
-    form-hook [ compose ] change ;
-
-: hidden-form-field ( -- )
-    form-hook get call ;
-
-: absolute-redirect ( to query -- url )
-    #! Same host.
-    request get clone
-    swap [ >>query ] when*
-    swap url-encode >>path
-    [ modify-query ] change-query
-    request-url ;
-
-: replace-last-component ( path with -- path' )
-    [ "/" 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> ;
-
-: <temporary-redirect> ( to query -- response )
-    307 "Temporary Redirect" <redirect> ;
-
-: <standard-redirect> ( to query -- response )
-    request get method>> "POST" =
-    [ <permanent-redirect> ] [ <temporary-redirect> ] if ;
-
-TUPLE: dispatcher default responders ;
-
-: new-dispatcher ( class -- dispatcher )
-    new
-        404-responder get >>default
-        H{ } clone >>responders ; inline
-
-: <dispatcher> ( -- dispatcher )
-    dispatcher new-dispatcher ;
-
-: find-responder ( path dispatcher -- path responder )
-    over empty? [
-        "" over responders>> at*
-        [ nip ] [ drop default>> ] if
-    ] [
-        over first over responders>> at*
-        [ [ drop rest-slice ] dip ] [ drop default>> ] if
-    ] if ;
-
-M: dispatcher call-responder* ( path dispatcher -- response )
-    find-responder call-responder ;
-
-TUPLE: vhost-dispatcher default responders ;
-
-: <vhost-dispatcher> ( -- dispatcher )
-    404-responder get H{ } clone vhost-dispatcher boa ;
-
-: find-vhost ( dispatcher -- responder )
-    request get host>> over responders>> at*
-    [ nip ] [ drop default>> ] if ;
-
-M: vhost-dispatcher call-responder* ( path dispatcher -- response )
-    find-vhost call-responder ;
-
-: add-responder ( dispatcher responder path -- dispatcher )
-    pick responders>> set-at ;
-
-: add-main-responder ( dispatcher responder path -- dispatcher )
-    [ add-responder drop ]
-    [ drop "" add-responder drop ]
-    [ 2drop ] 3tri ;
-
-TUPLE: filter-responder responder ;
-
-M: filter-responder call-responder*
-    responder>> call-responder ;
-
-SYMBOL: main-responder
-
-main-responder global
-[ drop 404-responder get-global ] cache
-drop
-
-SYMBOL: development-mode
 
 : http-error. ( error -- )
     "Internal server error" [
-        development-mode get [
         [ print-error nl :c ] with-html-stream
-        ] [
-            500 "Internal server error"
-            trivial-response-body
-        ] if
     ] simple-page ;
 
 : <500> ( error -- response )
     500 "Internal server error" <trivial-response>
-    swap '[ , http-error. ] >>body ;
+    development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ;
 
 : do-response ( response -- )
     dup write-response
     request get method>> "HEAD" =
-    [ drop ] [
+    [ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ;
-        '[
-            , write-response-body
-        ] [
-            http-error.
-        ] recover
-    ] if ;
 
 LOG: httpd-hit NOTICE
 
 : 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
-    [ ] link-hook set
+    V{ } clone responder-nesting set ;
-    [ ] form-hook set ;
+
+: dispatch-request ( request -- response )
+    url>> path>> split-path main-responder get call-responder ;
 
 : do-request ( request -- response )
-    [
+    '[
-        init-request
+        ,
-        [ request set ]
+        [ init-request ]
         [ log-request ]
-        [ path>> split-path main-responder get call-responder ] tri
+        [ dispatch-request ] tri
-        [ <404> ] unless*
+    ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
-    ] [
-        [ \ do-request log-error ]
-        [ <500> ]
-        bi
-    ] recover ;
 
 : ?refresh-all ( -- )
     development-mode get-global
@@ -287,8 +85,7 @@ SYMBOL: exit-continuation
 
 : httpd ( port -- )
     dup integer? [ internet-server ] when
-    "http.server" latin1
+    "http.server" latin1 [ handle-client ] with-server ;
-    [ handle-client ] with-server ;
 
 : httpd-main ( -- )
     8888 httpd ;

extra/http/server/static/static.factor

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

@@ -0,0 +1,6 @@
+IN: mime-types.tests
+USING: mime-types tools.test ;
+
+[ "application/postscript" ] [ "foo.ps" mime-type ] unit-test
+[ "application/octet-stream" ] [ "foo.ps.gz" mime-type ] unit-test
+[ "text/plain" ] [ "foo.factor" mime-type ] unit-test

extra/mime-types/mime-types.factor

@@ -0,0 +1,23 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files io.encodings.ascii assocs sequences splitting
+kernel namespaces fry memoize ;
+IN: mime-types
+
+MEMO: mime-db ( -- seq )
+    "resource:extra/mime-types/mime.types" ascii file-lines
+    [ "#" head? not ] filter [ " \t" split harvest ] map harvest ;
+
+: nonstandard-mime-types ( -- assoc )
+    H{
+        { "factor" "text/plain"                       }
+        { "cgi"    "application/x-cgi-script"         }
+        { "fhtml"  "application/x-factor-server-page" }
+    } ;
+
+MEMO: mime-types ( -- assoc )
+    [ mime-db [ unclip '[ , _ set ] each ] each ] H{ } make-assoc
+    nonstandard-mime-types assoc-union ;
+
+: mime-type ( filename -- mime-type )
+    file-extension mime-types at "application/octet-stream" or ;

extra/mime-types/mime.types

@@ -0,0 +1,988 @@
+# This is a comment. I love comments.
+
+# This file controls what Internet media types are sent to the client for
+# given file extension(s).  Sending the correct media type to the client
+# is important so they know how to handle the content of the file.
+# Extra types can either be added here or by using an AddType directive
+# in your config files. For more information about Internet media types,
+# please read RFC 2045, 2046, 2047, 2048, and 2077.  The Internet media type
+# registry is at <http://www.iana.org/assignments/media-types/>.
+
+# MIME type					Extensions
+application/activemessage
+application/andrew-inset			ez
+application/applefile
+application/atom+xml				atom
+application/atomcat+xml				atomcat
+application/atomicmail
+application/atomsvc+xml				atomsvc
+application/auth-policy+xml
+application/batch-smtp
+application/beep+xml
+application/cals-1840
+application/ccxml+xml				ccxml
+application/cellml+xml
+application/cnrp+xml
+application/commonground
+application/conference-info+xml
+application/cpl+xml
+application/csta+xml
+application/cstadata+xml
+application/cybercash
+application/davmount+xml			davmount
+application/dca-rft
+application/dec-dx
+application/dialog-info+xml
+application/dicom
+application/dns
+application/dvcs
+application/ecmascript				ecma
+application/edi-consent
+application/edi-x12
+application/edifact
+application/epp+xml
+application/eshop
+application/fastinfoset
+application/fastsoap
+application/fits
+application/font-tdpfr				pfr
+application/h224
+application/http
+application/hyperstudio				stk
+application/iges
+application/im-iscomposing+xml
+application/index
+application/index.cmd
+application/index.obj
+application/index.response
+application/index.vnd
+application/iotp
+application/ipp
+application/isup
+application/javascript				js
+application/json				json
+application/kpml-request+xml
+application/kpml-response+xml
+application/mac-binhex40			hqx
+application/mac-compactpro			cpt
+application/macwriteii
+application/marc				mrc
+application/mathematica				ma nb mb
+application/mathml+xml				mathml
+application/mbms-associated-procedure-description+xml
+application/mbms-deregister+xml
+application/mbms-envelope+xml
+application/mbms-msk+xml
+application/mbms-msk-response+xml
+application/mbms-protection-description+xml
+application/mbms-reception-report+xml
+application/mbms-register+xml
+application/mbms-register-response+xml
+application/mbms-user-service-description+xml
+application/mbox				mbox
+application/mediaservercontrol+xml		mscml
+application/mikey
+application/mp4					mp4s
+application/mpeg4-generic
+application/mpeg4-iod
+application/mpeg4-iod-xmt
+application/msword				doc dot
+application/mxf					mxf
+application/nasdata
+application/news-message-id
+application/news-transmission
+application/nss
+application/ocsp-request
+application/ocsp-response
+application/octet-stream bin dms lha lzh class so iso dmg dist distz pkg bpk dump elc scpt
+application/oda					oda
+application/oebps-package+xml
+application/ogg					ogg
+application/parityfec
+application/pdf					pdf
+application/pgp-encrypted			pgp
+application/pgp-keys
+application/pgp-signature			asc sig
+application/pics-rules				prf
+application/pidf+xml
+application/pkcs10				p10
+application/pkcs7-mime				p7m p7c
+application/pkcs7-signature			p7s
+application/pkix-cert				cer
+application/pkix-crl				crl
+application/pkix-pkipath			pkipath
+application/pkixcmp				pki
+application/pls+xml				pls
+application/poc-settings+xml
+application/postscript				ai eps ps
+application/prs.alvestrand.titrax-sheet
+application/prs.cww				cww
+application/prs.nprend
+application/prs.plucker
+application/qsig
+application/rdf+xml				rdf
+application/reginfo+xml				rif
+application/relax-ng-compact-syntax		rnc
+application/remote-printing
+application/resource-lists+xml			rl
+application/riscos
+application/rlmi+xml
+application/rls-services+xml			rs
+application/rsd+xml				rsd
+application/rss+xml				rss
+application/rtf					rtf
+application/rtx
+application/samlassertion+xml
+application/samlmetadata+xml
+application/sbml+xml				sbml
+application/sdp					sdp
+application/set-payment
+application/set-payment-initiation		setpay
+application/set-registration
+application/set-registration-initiation		setreg
+application/sgml
+application/sgml-open-catalog
+application/shf+xml				shf
+application/sieve
+application/simple-filter+xml
+application/simple-message-summary
+application/simplesymbolcontainer
+application/slate
+application/smil
+application/smil+xml				smi smil
+application/soap+fastinfoset
+application/soap+xml
+application/spirits-event+xml
+application/srgs				gram
+application/srgs+xml				grxml
+application/ssml+xml				ssml
+application/timestamp-query
+application/timestamp-reply
+application/tve-trigger
+application/vemmi
+application/vividence.scriptfile
+application/vnd.3gpp.bsf+xml
+application/vnd.3gpp.pic-bw-large		plb
+application/vnd.3gpp.pic-bw-small		psb
+application/vnd.3gpp.pic-bw-var			pvb
+application/vnd.3gpp.sms
+application/vnd.3gpp2.bcmcsinfo+xml
+application/vnd.3gpp2.sms
+application/vnd.3m.post-it-notes		pwn
+application/vnd.accpac.simply.aso		aso
+application/vnd.accpac.simply.imp		imp
+application/vnd.acucobol			acu
+application/vnd.acucorp				atc acutc
+application/vnd.adobe.xdp+xml			xdp
+application/vnd.adobe.xfdf			xfdf
+application/vnd.aether.imp
+application/vnd.amiga.ami			ami
+application/vnd.anser-web-certificate-issue-initiation	cii
+application/vnd.anser-web-funds-transfer-initiation	fti
+application/vnd.antix.game-component		atx
+application/vnd.apple.installer+xml		mpkg
+application/vnd.audiograph			aep
+application/vnd.autopackage
+application/vnd.avistar+xml
+application/vnd.blueice.multipass		mpm
+application/vnd.bmi				bmi
+application/vnd.businessobjects			rep
+application/vnd.cab-jscript
+application/vnd.canon-cpdl
+application/vnd.canon-lips
+application/vnd.cendio.thinlinc.clientconf
+application/vnd.chemdraw+xml			cdxml
+application/vnd.chipnuts.karaoke-mmd		mmd
+application/vnd.cinderella			cdy
+application/vnd.cirpack.isdn-ext
+application/vnd.claymore			cla
+application/vnd.clonk.c4group			c4g c4d c4f c4p c4u
+application/vnd.commerce-battelle
+application/vnd.commonspace			csp cst
+application/vnd.contact.cmsg			cdbcmsg
+application/vnd.cosmocaller			cmc
+application/vnd.crick.clicker			clkx
+application/vnd.crick.clicker.keyboard		clkk
+application/vnd.crick.clicker.palette		clkp
+application/vnd.crick.clicker.template		clkt
+application/vnd.crick.clicker.wordbank		clkw
+application/vnd.criticaltools.wbs+xml		wbs
+application/vnd.ctc-posml			pml
+application/vnd.cups-pdf
+application/vnd.cups-postscript
+application/vnd.cups-ppd			ppd
+application/vnd.cups-raster
+application/vnd.cups-raw
+application/vnd.curl				curl
+application/vnd.cybank
+application/vnd.data-vision.rdz			rdz
+application/vnd.denovo.fcselayout-link		fe_launch
+application/vnd.dna				dna
+application/vnd.dolby.mlp			mlp
+application/vnd.dpgraph				dpg
+application/vnd.dreamfactory			dfac
+application/vnd.dvb.esgcontainer
+application/vnd.dvb.ipdcesgaccess
+application/vnd.dxr
+application/vnd.ecdis-update
+application/vnd.ecowin.chart			mag
+application/vnd.ecowin.filerequest
+application/vnd.ecowin.fileupdate
+application/vnd.ecowin.series
+application/vnd.ecowin.seriesrequest
+application/vnd.ecowin.seriesupdate
+application/vnd.enliven				nml
+application/vnd.epson.esf			esf
+application/vnd.epson.msf			msf
+application/vnd.epson.quickanime		qam
+application/vnd.epson.salt			slt
+application/vnd.epson.ssf			ssf
+application/vnd.ericsson.quickcall
+application/vnd.eszigno3+xml			es3 et3
+application/vnd.eudora.data
+application/vnd.ezpix-album			ez2
+application/vnd.ezpix-package			ez3
+application/vnd.fdf				fdf
+application/vnd.ffsns
+application/vnd.fints
+application/vnd.flographit			gph
+application/vnd.fluxtime.clip			ftc
+application/vnd.framemaker			fm frame maker
+application/vnd.frogans.fnc			fnc
+application/vnd.frogans.ltf			ltf
+application/vnd.fsc.weblaunch			fsc
+application/vnd.fujitsu.oasys			oas
+application/vnd.fujitsu.oasys2			oa2
+application/vnd.fujitsu.oasys3			oa3
+application/vnd.fujitsu.oasysgp			fg5
+application/vnd.fujitsu.oasysprs		bh2
+application/vnd.fujixerox.art-ex
+application/vnd.fujixerox.art4
+application/vnd.fujixerox.hbpl
+application/vnd.fujixerox.ddd			ddd
+application/vnd.fujixerox.docuworks		xdw
+application/vnd.fujixerox.docuworks.binder	xbd
+application/vnd.fut-misnet
+application/vnd.fuzzysheet			fzs
+application/vnd.genomatix.tuxedo		txd
+application/vnd.google-earth.kml+xml		kml
+application/vnd.google-earth.kmz		kmz
+application/vnd.grafeq				gqf gqs
+application/vnd.gridmp
+application/vnd.groove-account			gac
+application/vnd.groove-help			ghf
+application/vnd.groove-identity-message		gim
+application/vnd.groove-injector			grv
+application/vnd.groove-tool-message		gtm
+application/vnd.groove-tool-template		tpl
+application/vnd.groove-vcard			vcg
+application/vnd.handheld-entertainment+xml	zmm
+application/vnd.hbci				hbci
+application/vnd.hcl-bireports
+application/vnd.hhe.lesson-player		les
+application/vnd.hp-hpgl				hpgl
+application/vnd.hp-hpid				hpid
+application/vnd.hp-hps				hps
+application/vnd.hp-jlyt				jlt
+application/vnd.hp-pcl				pcl
+application/vnd.hp-pclxl			pclxl
+application/vnd.httphone
+application/vnd.hzn-3d-crossword		x3d
+application/vnd.ibm.afplinedata
+application/vnd.ibm.electronic-media
+application/vnd.ibm.minipay			mpy
+application/vnd.ibm.modcap			afp listafp list3820
+application/vnd.ibm.rights-management		irm
+application/vnd.ibm.secure-container		sc
+application/vnd.igloader			igl
+application/vnd.immervision-ivp			ivp
+application/vnd.immervision-ivu			ivu
+application/vnd.informedcontrol.rms+xml
+application/vnd.intercon.formnet		xpw xpx
+application/vnd.intertrust.digibox
+application/vnd.intertrust.nncp
+application/vnd.intu.qbo			qbo
+application/vnd.intu.qfx			qfx
+application/vnd.ipunplugged.rcprofile		rcprofile
+application/vnd.irepository.package+xml		irp
+application/vnd.is-xpr				xpr
+application/vnd.jam				jam
+application/vnd.japannet-directory-service
+application/vnd.japannet-jpnstore-wakeup
+application/vnd.japannet-payment-wakeup
+application/vnd.japannet-registration
+application/vnd.japannet-registration-wakeup
+application/vnd.japannet-setstore-wakeup
+application/vnd.japannet-verification
+application/vnd.japannet-verification-wakeup
+application/vnd.jcp.javame.midlet-rms		rms
+application/vnd.jisp				jisp
+application/vnd.kahootz				ktz ktr
+application/vnd.kde.karbon			karbon
+application/vnd.kde.kchart			chrt
+application/vnd.kde.kformula			kfo
+application/vnd.kde.kivio			flw
+application/vnd.kde.kontour			kon
+application/vnd.kde.kpresenter			kpr kpt
+application/vnd.kde.kspread			ksp
+application/vnd.kde.kword			kwd kwt
+application/vnd.kenameaapp			htke
+application/vnd.kidspiration			kia
+application/vnd.kinar				kne knp
+application/vnd.koan				skp skd skt skm
+application/vnd.liberty-request+xml
+application/vnd.llamagraphics.life-balance.desktop	lbd
+application/vnd.llamagraphics.life-balance.exchange+xml	lbe
+application/vnd.lotus-1-2-3			123
+application/vnd.lotus-approach			apr
+application/vnd.lotus-freelance			pre
+application/vnd.lotus-notes			nsf
+application/vnd.lotus-organizer			org
+application/vnd.lotus-screencam			scm
+application/vnd.lotus-wordpro			lwp
+application/vnd.macports.portpkg		portpkg
+application/vnd.marlin.drm.actiontoken+xml
+application/vnd.marlin.drm.conftoken+xml
+application/vnd.marlin.drm.mdcf
+application/vnd.mcd				mcd
+application/vnd.medcalcdata			mc1
+application/vnd.mediastation.cdkey		cdkey
+application/vnd.meridian-slingshot
+application/vnd.mfer				mwf
+application/vnd.mfmp				mfm
+application/vnd.micrografx.flo			flo
+application/vnd.micrografx.igx			igx
+application/vnd.mif				mif
+application/vnd.minisoft-hp3000-save
+application/vnd.mitsubishi.misty-guard.trustweb
+application/vnd.mobius.daf			daf
+application/vnd.mobius.dis			dis
+application/vnd.mobius.mbk			mbk
+application/vnd.mobius.mqy			mqy
+application/vnd.mobius.msl			msl
+application/vnd.mobius.plc			plc
+application/vnd.mobius.txf			txf
+application/vnd.mophun.application		mpn
+application/vnd.mophun.certificate		mpc
+application/vnd.motorola.flexsuite
+application/vnd.motorola.flexsuite.adsi
+application/vnd.motorola.flexsuite.fis
+application/vnd.motorola.flexsuite.gotap
+application/vnd.motorola.flexsuite.kmr
+application/vnd.motorola.flexsuite.ttc
+application/vnd.motorola.flexsuite.wem
+application/vnd.mozilla.xul+xml	xul
+application/vnd.ms-artgalry			cil
+application/vnd.ms-asf				asf
+application/vnd.ms-cab-compressed		cab
+application/vnd.ms-excel			xls xlm xla xlc xlt xlw
+application/vnd.ms-fontobject			eot
+application/vnd.ms-htmlhelp			chm
+application/vnd.ms-ims				ims
+application/vnd.ms-lrm				lrm
+application/vnd.ms-playready.initiator+xml
+application/vnd.ms-powerpoint			ppt pps pot
+application/vnd.ms-project			mpp mpt
+application/vnd.ms-tnef
+application/vnd.ms-wmdrm.lic-chlg-req
+application/vnd.ms-wmdrm.lic-resp
+application/vnd.ms-wmdrm.meter-chlg-req
+application/vnd.ms-wmdrm.meter-resp
+application/vnd.ms-works			wps wks wcm wdb
+application/vnd.ms-wpl				wpl
+application/vnd.ms-xpsdocument			xps
+application/vnd.mseq				mseq
+application/vnd.msign
+application/vnd.music-niff
+application/vnd.musician			mus
+application/vnd.ncd.control
+application/vnd.nervana
+application/vnd.netfpx
+application/vnd.neurolanguage.nlu		nlu
+application/vnd.noblenet-directory		nnd
+application/vnd.noblenet-sealer			nns
+application/vnd.noblenet-web			nnw
+application/vnd.nokia.catalogs
+application/vnd.nokia.conml+wbxml
+application/vnd.nokia.conml+xml
+application/vnd.nokia.isds-radio-presets
+application/vnd.nokia.iptv.config+xml
+application/vnd.nokia.landmark+wbxml
+application/vnd.nokia.landmark+xml
+application/vnd.nokia.landmarkcollection+xml
+application/vnd.nokia.n-gage.ac+xml
+application/vnd.nokia.n-gage.data		ngdat
+application/vnd.nokia.n-gage.symbian.install	n-gage
+application/vnd.nokia.ncd
+application/vnd.nokia.pcd+wbxml
+application/vnd.nokia.pcd+xml
+application/vnd.nokia.radio-preset		rpst
+application/vnd.nokia.radio-presets		rpss
+application/vnd.novadigm.edm			edm
+application/vnd.novadigm.edx			edx
+application/vnd.novadigm.ext			ext
+application/vnd.oasis.opendocument.chart		odc
+application/vnd.oasis.opendocument.chart-template	otc
+application/vnd.oasis.opendocument.formula		odf
+application/vnd.oasis.opendocument.formula-template	otf
+application/vnd.oasis.opendocument.graphics		odg
+application/vnd.oasis.opendocument.graphics-template	otg
+application/vnd.oasis.opendocument.image		odi
+application/vnd.oasis.opendocument.image-template	oti
+application/vnd.oasis.opendocument.presentation		odp
+application/vnd.oasis.opendocument.presentation-template otp
+application/vnd.oasis.opendocument.spreadsheet		ods
+application/vnd.oasis.opendocument.spreadsheet-template	ots
+application/vnd.oasis.opendocument.text			odt
+application/vnd.oasis.opendocument.text-master		otm
+application/vnd.oasis.opendocument.text-template	ott
+application/vnd.oasis.opendocument.text-web		oth
+application/vnd.obn
+application/vnd.olpc-sugar			xo
+application/vnd.oma-scws-config
+application/vnd.oma-scws-http-request
+application/vnd.oma-scws-http-response
+application/vnd.oma.bcast.associated-procedure-parameter+xml
+application/vnd.oma.bcast.drm-trigger+xml
+application/vnd.oma.bcast.imd+xml
+application/vnd.oma.bcast.notification+xml
+application/vnd.oma.bcast.sgboot
+application/vnd.oma.bcast.sgdd+xml
+application/vnd.oma.bcast.sgdu
+application/vnd.oma.bcast.simple-symbol-container
+application/vnd.oma.bcast.smartcard-trigger+xml
+application/vnd.oma.bcast.sprov+xml
+application/vnd.oma.dd2+xml			dd2
+application/vnd.oma.drm.risd+xml
+application/vnd.oma.group-usage-list+xml
+application/vnd.oma.poc.groups+xml
+application/vnd.oma.xcap-directory+xml
+application/vnd.omads-email+xml
+application/vnd.omads-file+xml
+application/vnd.omads-folder+xml
+application/vnd.omaloc-supl-init
+application/vnd.openofficeorg.extension		oxt
+application/vnd.osa.netdeploy
+application/vnd.osgi.dp				dp
+application/vnd.otps.ct-kip+xml
+application/vnd.palm				prc pdb pqa oprc
+application/vnd.paos.xml
+application/vnd.pg.format			str
+application/vnd.pg.osasli			ei6
+application/vnd.piaccess.application-licence
+application/vnd.picsel				efif
+application/vnd.poc.group-advertisement+xml
+application/vnd.pocketlearn			plf
+application/vnd.powerbuilder6			pbd
+application/vnd.powerbuilder6-s
+application/vnd.powerbuilder7
+application/vnd.powerbuilder7-s
+application/vnd.powerbuilder75
+application/vnd.powerbuilder75-s
+application/vnd.preminet
+application/vnd.previewsystems.box		box
+application/vnd.proteus.magazine		mgz
+application/vnd.publishare-delta-tree		qps
+application/vnd.pvi.ptid1			ptid
+application/vnd.pwg-multiplexed
+application/vnd.pwg-xhtml-print+xml
+application/vnd.qualcomm.brew-app-res
+application/vnd.quark.quarkxpress		qxd qxt qwd qwt qxl qxb
+application/vnd.rapid
+application/vnd.recordare.musicxml		mxl
+application/vnd.recordare.musicxml+xml
+application/vnd.renlearn.rlprint
+application/vnd.rn-realmedia			rm
+application/vnd.ruckus.download
+application/vnd.s3sms
+application/vnd.scribus
+application/vnd.sealed.3df
+application/vnd.sealed.csf
+application/vnd.sealed.doc
+application/vnd.sealed.eml
+application/vnd.sealed.mht
+application/vnd.sealed.net
+application/vnd.sealed.ppt
+application/vnd.sealed.tiff
+application/vnd.sealed.xls
+application/vnd.sealedmedia.softseal.html
+application/vnd.sealedmedia.softseal.pdf
+application/vnd.seemail				see
+application/vnd.sema				sema
+application/vnd.semd				semd
+application/vnd.semf				semf
+application/vnd.shana.informed.formdata		ifm
+application/vnd.shana.informed.formtemplate	itp
+application/vnd.shana.informed.interchange	iif
+application/vnd.shana.informed.package		ipk
+application/vnd.simtech-mindmapper		twd twds
+application/vnd.smaf				mmf
+application/vnd.solent.sdkm+xml			sdkm sdkd
+application/vnd.spotfire.dxp			dxp
+application/vnd.spotfire.sfs			sfs
+application/vnd.sss-cod
+application/vnd.sss-dtf
+application/vnd.sss-ntf
+application/vnd.street-stream
+application/vnd.sun.wadl+xml
+application/vnd.sus-calendar			sus susp
+application/vnd.svd				svd
+application/vnd.swiftview-ics
+application/vnd.syncml+xml			xsm
+application/vnd.syncml.dm+wbxml			bdm
+application/vnd.syncml.dm+xml			xdm
+application/vnd.syncml.ds.notification
+application/vnd.tao.intent-module-archive	tao
+application/vnd.tmobile-livetv			tmo
+application/vnd.trid.tpt			tpt
+application/vnd.triscape.mxs			mxs
+application/vnd.trueapp				tra
+application/vnd.truedoc
+application/vnd.ufdl				ufd ufdl
+application/vnd.uiq.theme			utz
+application/vnd.umajin				umj
+application/vnd.unity				unityweb
+application/vnd.uoml+xml			uoml
+application/vnd.uplanet.alert
+application/vnd.uplanet.alert-wbxml
+application/vnd.uplanet.bearer-choice
+application/vnd.uplanet.bearer-choice-wbxml
+application/vnd.uplanet.cacheop
+application/vnd.uplanet.cacheop-wbxml
+application/vnd.uplanet.channel
+application/vnd.uplanet.channel-wbxml
+application/vnd.uplanet.list
+application/vnd.uplanet.list-wbxml
+application/vnd.uplanet.listcmd
+application/vnd.uplanet.listcmd-wbxml
+application/vnd.uplanet.signal
+application/vnd.vcx				vcx
+application/vnd.vd-study
+application/vnd.vectorworks
+application/vnd.vidsoft.vidconference
+application/vnd.visio				vsd vst vss vsw
+application/vnd.visionary			vis
+application/vnd.vividence.scriptfile
+application/vnd.vsf				vsf
+application/vnd.wap.sic
+application/vnd.wap.slc
+application/vnd.wap.wbxml			wbxml
+application/vnd.wap.wmlc			wmlc
+application/vnd.wap.wmlscriptc			wmlsc
+application/vnd.webturbo			wtb
+application/vnd.wfa.wsc
+application/vnd.wordperfect			wpd
+application/vnd.wqd				wqd
+application/vnd.wrq-hp3000-labelled
+application/vnd.wt.stf				stf
+application/vnd.wv.csp+wbxml
+application/vnd.wv.csp+xml
+application/vnd.wv.ssp+xml
+application/vnd.xara				xar
+application/vnd.xfdl				xfdl
+application/vnd.xmpie.cpkg
+application/vnd.xmpie.dpkg
+application/vnd.xmpie.plan
+application/vnd.xmpie.ppkg
+application/vnd.xmpie.xlim
+application/vnd.yamaha.hv-dic			hvd
+application/vnd.yamaha.hv-script		hvs
+application/vnd.yamaha.hv-voice			hvp
+application/vnd.yamaha.smaf-audio		saf
+application/vnd.yamaha.smaf-phrase		spf
+application/vnd.yellowriver-custom-menu		cmp
+application/vnd.zzazz.deck+xml			zaz
+application/voicexml+xml			vxml
+application/watcherinfo+xml
+application/whoispp-query
+application/whoispp-response
+application/winhlp				hlp
+application/wita
+application/wordperfect5.1
+application/wsdl+xml				wsdl
+application/wspolicy+xml			wspolicy
+application/x-ace-compressed			ace
+application/x-bcpio				bcpio
+application/x-bittorrent			torrent
+application/x-bzip				bz
+application/x-bzip2				bz2 boz
+application/x-cdlink				vcd
+application/x-chat				chat
+application/x-chess-pgn				pgn
+application/x-compress
+application/x-cpio				cpio
+application/x-csh				csh
+application/x-director				dcr dir dxr fgd
+application/x-dvi				dvi
+application/x-futuresplash			spl
+application/x-gtar				gtar
+application/x-gzip
+application/x-hdf				hdf
+application/x-java-jnlp-file	jnlp
+application/x-latex				latex
+application/x-ms-wmd				wmd
+application/x-ms-wmz				wmz
+application/x-msaccess				mdb
+application/x-msbinder				obd
+application/x-mscardfile			crd
+application/x-msclip				clp
+application/x-msdownload			exe dll com bat msi
+application/x-msmediaview			mvb m13 m14
+application/x-msmetafile			wmf
+application/x-msmoney				mny
+application/x-mspublisher			pub
+application/x-msschedule			scd
+application/x-msterminal			trm
+application/x-mswrite				wri
+application/x-netcdf				nc cdf
+application/x-pkcs12				p12 pfx
+application/x-pkcs7-certificates		p7b spc
+application/x-pkcs7-certreqresp			p7r
+application/x-rar-compressed			rar
+application/x-sh				sh
+application/x-shar				shar
+application/x-shockwave-flash			swf
+application/x-stuffit				sit
+application/x-stuffitx				sitx
+application/x-sv4cpio				sv4cpio
+application/x-sv4crc				sv4crc
+application/x-tar				tar
+application/x-tcl				tcl
+application/x-tex				tex
+application/x-texinfo				texinfo texi
+application/x-ustar				ustar
+application/x-wais-source			src
+application/x-x509-ca-cert			der crt
+application/x400-bp
+application/xcap-att+xml
+application/xcap-caps+xml
+application/xcap-el+xml
+application/xcap-error+xml
+application/xcap-ns+xml
+application/xenc+xml				xenc
+application/xhtml+xml				xhtml xht
+application/xml					xml xsl
+application/xml-dtd				dtd
+application/xml-external-parsed-entity
+application/xmpp+xml
+application/xop+xml				xop
+application/xslt+xml				xslt
+application/xspf+xml				xspf
+application/xv+xml				mxml xhvml xvml xvm
+application/zip					zip
+audio/32kadpcm
+audio/3gpp
+audio/3gpp2
+audio/ac3
+audio/amr
+audio/amr-wb
+audio/amr-wb+
+audio/asc
+audio/basic					au snd
+audio/bv16
+audio/bv32
+audio/clearmode
+audio/cn
+audio/dat12
+audio/dls
+audio/dsr-es201108
+audio/dsr-es202050
+audio/dsr-es202211
+audio/dsr-es202212
+audio/dvi4
+audio/eac3
+audio/evrc
+audio/evrc-qcp
+audio/evrc0
+audio/evrc1
+audio/evrcb
+audio/evrcb0
+audio/evrcb1
+audio/g722
+audio/g7221
+audio/g723
+audio/g726-16
+audio/g726-24
+audio/g726-32
+audio/g726-40
+audio/g728
+audio/g729
+audio/g7291
+audio/g729d
+audio/g729e
+audio/gsm
+audio/gsm-efr
+audio/ilbc
+audio/l16
+audio/l20
+audio/l24
+audio/l8
+audio/lpc
+audio/midi					mid midi kar rmi
+audio/mobile-xmf
+audio/mp4					mp4a
+audio/mp4a-latm			m4a m4p
+audio/mpa
+audio/mpa-robust
+audio/mpeg					mpga mp2 mp2a mp3 m2a m3a
+audio/mpeg4-generic
+audio/parityfec
+audio/pcma
+audio/pcmu
+audio/prs.sid
+audio/qcelp
+audio/red
+audio/rtp-enc-aescm128
+audio/rtp-midi
+audio/rtx
+audio/smv
+audio/smv0
+audio/smv-qcp
+audio/sp-midi
+audio/t140c
+audio/t38
+audio/telephone-event
+audio/tone
+audio/vdvi
+audio/vmr-wb
+audio/vnd.3gpp.iufp
+audio/vnd.4sb
+audio/vnd.audiokoz
+audio/vnd.celp
+audio/vnd.cisco.nse
+audio/vnd.cmles.radio-events
+audio/vnd.cns.anp1
+audio/vnd.cns.inf1
+audio/vnd.digital-winds				eol
+audio/vnd.dlna.adts
+audio/vnd.dolby.mlp
+audio/vnd.everad.plj
+audio/vnd.hns.audio
+audio/vnd.lucent.voice				lvp
+audio/vnd.nokia.mobile-xmf
+audio/vnd.nortel.vbk
+audio/vnd.nuera.ecelp4800			ecelp4800
+audio/vnd.nuera.ecelp7470			ecelp7470
+audio/vnd.nuera.ecelp9600			ecelp9600
+audio/vnd.octel.sbc
+audio/vnd.qcelp
+audio/vnd.rhetorex.32kadpcm
+audio/vnd.sealedmedia.softseal.mpeg
+audio/vnd.vmx.cvsd
+audio/wav					wav
+audio/x-aiff					aif aiff aifc
+audio/x-mpegurl					m3u
+audio/x-ms-wax					wax
+audio/x-ms-wma					wma
+audio/x-pn-realaudio				ram ra
+audio/x-pn-realaudio-plugin			rmp
+audio/x-wav					wav
+chemical/x-cdx					cdx
+chemical/x-cif					cif
+chemical/x-cmdf					cmdf
+chemical/x-cml					cml
+chemical/x-csml					csml
+chemical/x-pdb					pdb
+chemical/x-xyz					xyz
+image/bmp					bmp
+image/cgm					cgm
+image/fits
+image/g3fax					g3
+image/gif					gif
+image/ief					ief
+image/jp2			jp2
+image/jpeg					jpeg jpg jpe
+image/jpm
+image/jpx
+image/naplps
+image/pict			pict pic pct
+image/png					png
+image/prs.btif					btif
+image/prs.pti
+image/svg+xml					svg svgz
+image/t38
+image/tiff					tiff tif
+image/tiff-fx
+image/vnd.adobe.photoshop			psd
+image/vnd.cns.inf2
+image/vnd.djvu					djvu djv
+image/vnd.dwg					dwg
+image/vnd.dxf					dxf
+image/vnd.fastbidsheet				fbs
+image/vnd.fpx					fpx
+image/vnd.fst					fst
+image/vnd.fujixerox.edmics-mmr			mmr
+image/vnd.fujixerox.edmics-rlc			rlc
+image/vnd.globalgraphics.pgb
+image/vnd.microsoft.icon			ico
+image/vnd.mix
+image/vnd.ms-modi				mdi
+image/vnd.net-fpx				npx
+image/vnd.sealed.png
+image/vnd.sealedmedia.softseal.gif
+image/vnd.sealedmedia.softseal.jpg
+image/vnd.svf
+image/vnd.wap.wbmp				wbmp
+image/vnd.xiff					xif
+image/x-cmu-raster				ras
+image/x-cmx					cmx
+image/x-icon
+image/x-macpaint		pntg pnt mac
+image/x-pcx					pcx
+image/x-pict					pic pct
+image/x-portable-anymap				pnm
+image/x-portable-bitmap				pbm
+image/x-portable-graymap			pgm
+image/x-portable-pixmap				ppm
+image/x-quicktime		qtif qti
+image/x-rgb					rgb
+image/x-xbitmap					xbm
+image/x-xpixmap					xpm
+image/x-xwindowdump				xwd
+message/cpim
+message/delivery-status
+message/disposition-notification
+message/external-body
+message/http
+message/news
+message/partial
+message/rfc822					eml mime
+message/s-http
+message/sip
+message/sipfrag
+message/tracking-status
+model/iges					igs iges
+model/mesh					msh mesh silo
+model/vnd.dwf					dwf
+model/vnd.flatland.3dml
+model/vnd.gdl					gdl
+model/vnd.gs.gdl
+model/vnd.gtw					gtw
+model/vnd.moml+xml
+model/vnd.mts					mts
+model/vnd.parasolid.transmit.binary
+model/vnd.parasolid.transmit.text
+model/vnd.vtu					vtu
+model/vrml					wrl vrml
+multipart/alternative
+multipart/appledouble
+multipart/byteranges
+multipart/digest
+multipart/encrypted
+multipart/form-data
+multipart/header-set
+multipart/mixed
+multipart/parallel
+multipart/related
+multipart/report
+multipart/signed
+multipart/voice-message
+text/calendar					ics ifb
+text/css					css
+text/csv					csv
+text/directory
+text/dns
+text/enriched
+text/html					html htm
+text/parityfec
+text/plain					txt text conf def list log in
+text/prs.fallenstein.rst
+text/prs.lines.tag				dsc
+text/red
+text/rfc822-headers
+text/richtext					rtx
+text/rtf
+text/rtp-enc-aescm128
+text/rtx
+text/sgml					sgml sgm
+text/t140
+text/tab-separated-values			tsv
+text/troff					t tr roff man me ms
+text/uri-list					uri uris urls
+text/vnd.abc
+text/vnd.curl
+text/vnd.dmclientscript
+text/vnd.esmertec.theme-descriptor
+text/vnd.fly					fly
+text/vnd.fmi.flexstor				flx
+text/vnd.in3d.3dml				3dml
+text/vnd.in3d.spot				spot
+text/vnd.iptc.newsml
+text/vnd.iptc.nitf
+text/vnd.latex-z
+text/vnd.motorola.reflex
+text/vnd.ms-mediapackage
+text/vnd.net2phone.commcenter.command
+text/vnd.sun.j2me.app-descriptor		jad
+text/vnd.trolltech.linguist
+text/vnd.wap.si
+text/vnd.wap.sl
+text/vnd.wap.wml				wml
+text/vnd.wap.wmlscript				wmls
+text/x-asm					s asm
+text/x-c					c cc cxx cpp h hh dic
+text/x-fortran					f for f77 f90
+text/x-pascal					p pas
+text/x-java-source				java
+text/x-setext					etx
+text/x-uuencode					uu
+text/x-vcalendar				vcs
+text/x-vcard					vcf
+text/xml
+text/xml-external-parsed-entity
+video/3gpp					3gp
+video/3gpp-tt
+video/3gpp2					3g2
+video/bmpeg
+video/bt656
+video/celb
+video/dv
+video/h261					h261
+video/h263					h263
+video/h263-1998
+video/h263-2000
+video/h264					h264
+video/jpeg					jpgv
+video/jpm					jpm jpgm
+video/mj2					mj2 mjp2
+video/mp1s
+video/mp2p
+video/mp2t
+video/mp4					mp4 mp4v mpg4 m4v
+video/mp4v-es
+video/mpeg					mpeg mpg mpe m1v m2v
+video/mpeg4-generic
+video/mpv
+video/nv
+video/parityfec
+video/pointer
+video/quicktime					qt mov
+video/raw
+video/rtp-enc-aescm128
+video/rtx
+video/smpte292m
+video/vc1
+video/vnd.dlna.mpeg-tts
+video/vnd.fvt					fvt
+video/vnd.hns.video
+video/vnd.motorola.video
+video/vnd.motorola.videop
+video/vnd.mpegurl				mxu m4u
+video/vnd.nokia.interleaved-multimedia
+video/vnd.nokia.videovoip
+video/vnd.objectvideo
+video/vnd.sealed.mpeg1
+video/vnd.sealed.mpeg4
+video/vnd.sealed.swf
+video/vnd.sealedmedia.softseal.mov
+video/vnd.vivo					viv
+video/x-dv			dv dif
+video/x-fli					fli
+video/x-ms-asf					asf asx
+video/x-ms-wm					wm
+video/x-ms-wmv					wmv
+video/x-ms-wmx					wmx
+video/x-ms-wvx					wvx
+video/x-msvideo					avi
+video/x-sgi-movie				movie
+x-conference/x-cooltalk				ice

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,10 @@
 ! 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 http.server.dispatchers http.server.responses
+http.server.static furnace.actions furnace.json
+io io.files json.writer kernel math.parser namespaces
+semantic-db sequences strings tangle.path ;
 IN: tangle
 
 GENERIC: render* ( content templater -- output )
@@ -20,7 +24,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 +40,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 +56,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/unicode/collation/collation-docs.factor

@@ -1,7 +1,42 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup strings byte-arrays ;
 IN: unicode.collation
 
 ABOUT: "unicode.collation"
 
 ARTICLE: "unicode.collation" "Unicode collation algorithm"
-"The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode." ;
+"The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are defined:"
+{ $subsection sort-strings }
+{ $subsection collation-key }
+{ $subsection string<=> }
+{ $subsection primary= }
+{ $subsection secondary= }
+{ $subsection tertiary= }
+{ $subsection quaternary= } ;
+
+HELP: sort-strings
+{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in DUCET order" } }
+{ $description "This word takes a sequence of strings and sorts them according to the UCA, using code point order as a tie-breaker." } ;
+
+HELP: collation-key
+{ $values { "string" string } { "key" byte-array } }
+{ $description "This takes a string and gives a representation of the collation key, which can be compared with <=>" } ;
+
+HELP: string<=>
+{ $values { "str1" string } { "str2" string } { "<=>" "one of +lt+, +gt+ or +eq+" } }
+{ $description "This word takes two strings and compares them using the UCA with the DUCET, using code point order as a tie-breaker." } ;
+
+HELP: primary=
+{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
+{ $description "This checks whether the first level of collation is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation and accent marks." } ;
+
+HELP: secondary=
+{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
+{ $description "This checks whether the first two levels of collation are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to primary=." } ;
+
+HELP: tertiary=
+{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
+{ $description "Along the same lines as secondary=, but case is significant." } ;
+
+HELP: quaternary=
+{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
+{ $description "This is similar to tertiary= but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ;

extra/unicode/collation/collation-tests.factor

@@ -24,6 +24,9 @@ IN: unicode.collation.tests
 [ t t f f ] [ "hello" "HELLO" test-equality ] unit-test
 [ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test
 [ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test
+[ { "good bye" "goodbye" "hello" "HELLO" } ]
+[ { "HELLO" "goodbye" "good bye" "hello" } sort-strings ]
+unit-test
 
 parse-test 2 <clumps>
 [ [ test-two ] assoc-each ] with-null-writer

extra/unicode/collation/collation.factor

@@ -6,6 +6,7 @@ unicode.syntax macros sequences.deep words unicode.breaks
 quotations ;
 IN: unicode.collation
 
+<PRIVATE
 VALUE: ducet
 
 TUPLE: weight primary secondary tertiary ignorable? ;
@@ -115,6 +116,7 @@ ducet insert-helpers
             [ [ variable-weight ] each ]
         } cleave
     ] { } make ;
+PRIVATE>
 
 : completely-ignorable? ( weight -- ? )
     [ primary>> ] [ secondary>> ] [ tertiary>> ] tri
@@ -131,11 +133,13 @@ ducet insert-helpers
     nfd string>graphemes graphemes>weights
     filter-ignorable weights>bytes ;
 
+<PRIVATE
 : insensitive= ( str1 str2 levels-removed -- ? )
     [
         swap collation-key swap
         [ [ 0 = not ] right-trim but-last ] times
     ] curry bi@ = ;
+PRIVATE>
 
 : primary= ( str1 str2 -- ? )
     3 insensitive= ;
@@ -149,17 +153,14 @@ ducet insert-helpers
 : quaternary= ( str1 str2 -- ? )
     0 insensitive= ;
 
-: compare-collation ( {str1,key} {str2,key} -- <=> )
+<PRIVATE
-    2dup [ second ] bi@ <=> dup +eq+ =
-    [ drop <=> ] [ 2nip ] if ;
-
 : w/collation-key ( str -- {str,key} )
-    dup collation-key 2array ;
+    [ collation-key ] keep 2array ;
+PRIVATE>
 
 : sort-strings ( strings -- sorted )
     [ w/collation-key ] map
-    [ compare-collation ] sort
+    natural-sort values ;
-    keys ;
 
 : string<=> ( str1 str2 -- <=> )
-    [ w/collation-key ] bi@ compare-collation ;
+    [ w/collation-key ] compare ;

extra/urls/urls-tests.factor

@@ -77,10 +77,36 @@ USING: urls tools.test tuple-syntax arrays kernel assocs ;
             }
             "a/relative/path"
         }
+        {
+            TUPLE{ url
+                path: "bar"
+                query: H{ { "a" "b" } }
+            }
+            "bar?a=b"
+        }
+        {
+            TUPLE{ url
+                protocol: "ftp"
+                host: "ftp.kernel.org"
+                username: "slava"
+                path: "/"
+            }
+            "ftp://slava@ftp.kernel.org/"
+        }
+        {
+            TUPLE{ url
+                protocol: "ftp"
+                host: "ftp.kernel.org"
+                username: "slava"
+                password: "secret"
+                path: "/"
+            }
+            "ftp://slava:secret@ftp.kernel.org/"
+        }
     } ;
 
 urls [
-    [ 1array ] [ [ string>url ] curry ] bi* unit-test
+    [ 1array ] [ [ >url ] curry ] bi* unit-test
 ] assoc-each
 
 urls [
@@ -192,3 +218,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,10 @@
 ! 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.sockets
-io.encodings.string io.encodings.utf8
+io.sockets.secure io.encodings.string io.encodings.utf8
-math math.parser accessors namespaces.lib ;
+math math.parser accessors mirrors parser
+prettyprint.backend hashtables ;
 IN: urls
 
 : url-quotable? ( ch -- ? )
@@ -89,13 +90,15 @@ IN: urls
         ] assoc-each
     ] { } make "&" join ;
 
-TUPLE: url protocol host port path query anchor ;
+TUPLE: url protocol username password host port path query anchor ;
 
-: query-param ( request key -- value )
+: <url> ( -- url ) url new ;
+
+: query-param ( url key -- value )
     swap query>> at ;
 
-: set-query-param ( request value key -- request )
+: set-query-param ( url value key -- url )
-    pick query>> set-at ;
+    '[ , , _ ?set-at ] change-query ;
 
 : parse-host ( string -- host port )
     ":" split1 [ url-decode ] [
@@ -105,40 +108,56 @@ 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 [
+            [
+                ":" split1 [ >>username ] [ >>password ] bi*
+            ] dip
+        ] when*
         "/" split1 [
-            parse-host [ "host" set ] [ "port" set ] bi*
+            parse-host [ >>host ] [ >>port ] bi*
         ] [ "/" prepend ] bi*
     ] bi* ;
 
-: string>url ( string -- url )
+GENERIC: >url ( obj -- url )
-    [
+
+M: url >url ;
+
+M: string >url
+    <url> swap
     ":" split1 [ parse-host-part ] when*
     "#" split1 [
-            "?" split1 [ query>assoc "query" set ] when*
+        "?" split1
-            url-decode "path" set
+        [ url-decode >>path ]
-        ] [
+        [ [ query>assoc >>query ] when* ] bi*
-            url-decode "anchor" set
+    ]
-        ] bi*
+    [ url-decode >>anchor ] bi* ;
-    ] url make-object ;
 
-: unparse-host-part ( protocol -- )
+: unparse-username-password ( url -- )
+    dup username>> dup [
+        % password>> [ ":" % % ] when* "@" %
+    ] [ 2drop ] if ;
+
+: unparse-host-part ( url protocol -- )
     %
     "://" %
-    "host" get url-encode %
+    {
-    "port" get [ ":" % # ] when*
+        [ unparse-username-password ]
-    "path" get "/" head? [ "Invalid URL" throw ] unless ;
+        [ host>> url-encode % ]
+        [ port>> [ ":" % # ] when* ]
+        [ path>> "/" head? [ "/" % ] unless ]
+    } cleave ;
 
 : 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 +177,26 @@ TUPLE: url protocol host port path query anchor ;
 
 : relative-url ( url -- url' )
     clone f >>protocol f >>host f >>port ;
+
+! Half-baked stuff follows
+: secure-protocol? ( protocol -- ? )
+    "https" = ;
+
+: url-addr ( url -- addr )
+    [ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
+    secure-protocol? [ <secure> ] when ;
+
+: protocol-port ( protocol -- port )
+    {
+        { "http" [ 80 ] }
+        { "https" [ 443 ] }
+        { "ftp" [ 21 ] }
+    } case ;
+
+: ensure-port ( url -- url' )
+    dup protocol>> '[ , protocol-port or ] change-port ;
+
+! Literal syntax
+: 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,7 @@
-USING: math kernel accessors html.components
+USING: math kernel accessors http.server http.server.dispatchers
-http.server http.server.actions
+furnace furnace.actions furnace.sessions
-http.server.sessions html.templates.chloe fry ;
+html.components html.templates.chloe
+fry urls ;
 IN: webapps.counter
 
 SYMBOL: count
@@ -11,15 +12,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,13 @@ USING: accessors kernel sequences assocs io.files io.sockets
 io.server
 namespaces db db.sqlite smtp
 http.server
-http.server.db
+http.server.dispatchers
-http.server.flows
+furnace.db
-http.server.sessions
+furnace.flows
-http.server.auth.login
+furnace.sessions
-http.server.auth.providers.db
+furnace.auth.login
-http.server.boilerplate
+furnace.auth.providers.db
-html.templates.chloe
+furnace.boilerplate
 webapps.pastebin
 webapps.planet
 webapps.todo
@@ -20,9 +20,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 +37,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 +52,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">
@@ -9,9 +11,9 @@
 		  <t:a t:href="$pastebin/list">Pastes</t:a>
 		| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
 
-		<t:if t:code="http.server.sessions:uid">
+		<t:if t:code="furnace.sessions:uid">
 
-			<t:if t:code="http.server.auth.login:allow-edit-profile?">
+			<t:if t:code="furnace.auth.login:allow-edit-profile?">
 				| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
 			</t:if>
 

extra/webapps/pastebin/pastebin.factor

@@ -2,15 +2,23 @@
 ! 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
+xmode.catalog validators
+html.components
+html.templates.chloe
 http.server
-http.server.actions
+http.server.dispatchers
-http.server.auth
+http.server.redirection
-http.server.auth.login
+furnace
-http.server.boilerplate ;
+furnace.actions
+furnace.auth
+furnace.auth.login
+furnace.boilerplate
+furnace.rss ;
 IN: webapps.pastebin
 
+TUPLE: pastebin < dispatcher ;
+
 ! ! !
 ! DOMAIN MODEL
 ! ! !
@@ -58,28 +66,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 +99,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 +107,7 @@ M: annotation entity-link
             swap
             [ summary>> >>title ]
             [ date>> >>pub-date ]
-            [ entity-link >>link ]
+            [ entity-link adjust-url relative-to-request >>link ]
             tri
     ] map ;
 
@@ -117,7 +128,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 +138,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 +146,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 relative-to-request >>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 +176,9 @@ M: annotation entity-link
             mode-names "modes" set-value
         ] >>init
 
-        "new-paste" pastebin-template >>template
+        { pastebin "new-paste" } >>template
+
+        [ mode-names "modes" set-value ] >>validate
 
         [
             validate-entity
@@ -173,7 +186,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 +197,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 +205,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 +220,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,12 +231,10 @@ M: annotation entity-link
         [
             f "id" value <annotation> select-tuple
             [ delete-tuples ]
-            [ parent>> "$pastebin/paste" <id-redirect> ]
+            [ parent>> paste-link <redirect> ]
             bi
         ] >>submit ;
 
-TUPLE: pastebin < dispatcher ;
-
 SYMBOL: can-delete-pastes?
 
 can-delete-pastes? define-capability
@@ -242,7 +250,7 @@ can-delete-pastes? define-capability
         <new-annotation-action> "new-annotation" add-responder
         <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
     <boilerplate>
-        "pastebin-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/entry-summary.xml

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

extra/webapps/planet/entry.xml

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

extra/webapps/planet/mini-planet.xml

@@ -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>
+			<t:a value="link" class="more">Read More...</t:a>
 		</p>
 
-	</t:each-tuple>
+	</t:bind-each>
 
 </t:chloe>

extra/webapps/planet/planet-common.xml

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

extra/webapps/planet/planet.factor

@@ -3,18 +3,22 @@
 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
+http.server.dispatchers
-http.server.boilerplate
+furnace
-http.server.auth.login
+furnace.actions
-http.server.auth ;
+furnace.boilerplate
+furnace.auth.login
+furnace.auth
+furnace.rss ;
 IN: webapps.planet
 
-: planet-template ( name -- template )
+TUPLE: planet-factor < dispatcher ;
-    "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
+
+TUPLE: planet-factor-admin < dispatcher ;
 
 TUPLE: blog id name www-url feed-url ;
 
@@ -61,7 +65,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 +74,7 @@ posting "POSTINGS"
             postings "postings" set-value
         ] >>init
 
-        "planet" planet-template >>template ;
+        { planet-factor "planet" } >>template ;
 
 : planet-feed ( -- feed )
     feed new
@@ -110,7 +114,7 @@ posting "POSTINGS"
     <action>
         [
             update-cached-postings
-            "" f <permanent-redirect>
+            URL" $planet-factor/admin" <redirect>
         ] >>submit ;
 
 : <delete-blog-action> ( -- action )
@@ -119,7 +123,7 @@ posting "POSTINGS"
 
         [
             "id" value <blog> delete-tuples
-            "$planet-factor/admin" f <standard-redirect>
+            URL" $planet-factor/admin" <redirect>
         ] >>submit ;
 
 : validate-blog ( -- )
@@ -129,15 +133,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 +146,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 +159,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,12 +173,15 @@ 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 ;
 
-TUPLE: planet-factor-admin < dispatcher ;
-
 : <planet-factor-admin> ( -- responder )
     planet-factor-admin new-dispatcher
         <edit-blogroll-action> "blogroll" add-main-responder
@@ -185,15 +194,13 @@ SYMBOL: can-administer-planet-factor?
 
 can-administer-planet-factor? define-capability
 
-TUPLE: planet-factor < dispatcher ;
-
 : <planet-factor> ( -- responder )
     planet-factor new-dispatcher
         <planet-action> "list" add-main-responder
         <feed-action> "feed.xml" add-responder
         <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
     <boilerplate>
-        "planet-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,10 +8,10 @@
 		<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>
+						<t:a t:value="link"><t:label t:name="title" /></t:a>
 					</h2>
 
 					<p class="posting-body">
@@ -19,10 +19,10 @@
 					</p>
 
 					<p class="posting-date">
-						<t:a t:value="link" t:session="none"><t:label t:name="pub-date" /></t:a>
+						<t:a t:value="link"><t:label t:name="pub-date" /></t:a>
 					</p>
 
-				</t: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: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,18 +1,22 @@
 ! 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
+http.server
-http.server.boilerplate
+http.server.dispatchers
-http.server.auth
+furnace
-http.server.actions
+furnace.sessions
-http.server.db
+furnace.boilerplate
-http.server.auth.login
+furnace.auth
-http.server ;
+furnace.actions
+furnace.db
+furnace.auth.login ;
 IN: webapps.todo
 
+TUPLE: todo-list < dispatcher ;
+
 TUPLE: todo uid id priority summary description ;
 
 todo "TODO"
@@ -31,20 +35,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 +55,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 +76,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 +90,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,15 +105,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 ;
 
 : <todo-list> ( -- responder )
     todo-list new-dispatcher
@@ -115,5 +121,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,9 +6,9 @@
 
 	<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:if t:code="furnace.auth.login:allow-edit-profile?">
 			| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
 		</t:if>
 

extra/webapps/user-admin/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,59 @@
 ! 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
-http.server.boilerplate
+furnace.boilerplate
-http.server.auth.providers
+furnace.auth.providers
-http.server.auth.providers.db
+furnace.auth.providers.db
-http.server.auth.login
+furnace.auth.login
-http.server.auth
+furnace.auth
-http.server.sessions
+furnace.sessions
-http.server.actions
+furnace.actions
-http.server ;
+http.server
+http.server.dispatchers ;
 IN: webapps.user-admin
 
-: admin-template ( name -- template )
+TUPLE: user-admin < dispatcher ;
-    "resource:extra/webapps/user-admin/" swap ".xml" 3append <chloe> ;
+
+: word>string ( word -- string )
+    [ 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 +76,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 +92,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 +109,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 +121,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,11 +141,9 @@ IN: webapps.user-admin
             [ logout-all-sessions ]
             bi
 
-            "$user-admin" f <standard-redirect>
+            URL" $user-admin" <redirect>
         ] >>submit ;
 
-TUPLE: user-admin < dispatcher ;
-
 SYMBOL: can-administer-users?
 
 can-administer-users? define-capability
@@ -146,7 +155,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-admin.xml

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

extra/webapps/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>