Fix problem with xml prologue showing up several times

extra/http/http.factor

@@ -394,16 +394,18 @@ body ;
     [ unparse-cookies "set-cookie" pick set-at ] when*
     write-header ;
 
-: body>quot ( body -- quot )
+GENERIC: write-response-body* ( body -- )
-    {
+
-        { [ dup not ] [ drop [ ] ] }
+M: f write-response-body* drop ;
-        { [ dup string? ] [ [ write ] curry ] }
+
-        { [ dup callable? ] [ ] }
+M: string write-response-body* write ;
-        [ [ stdio get stream-copy ] curry ]
+
-    } cond ;
+M: callable write-response-body* call ;
+
+M: object write-response-body* stdio get stream-copy ;
 
 : write-response-body ( response -- response )
-    dup body>> body>quot call ;
+    dup body>> write-response-body* ;
 
 M: response write-response ( respose -- )
     write-response-version

extra/http/server/auth/login/login.factor

@@ -68,10 +68,7 @@ M: user-saver dispose
         <action>
             [ blank-values ] >>init
 
-            [
+            [ form edit-form ] >>display
-                "text/html" <content>
-                [ form edit-form ] >>body
-            ] >>display
 
             [
                 blank-values
@@ -120,10 +117,7 @@ SYMBOL: user-exists?
         <action>
             [ blank-values ] >>init
 
-            [
+            [ form edit-form ] >>display
-                "text/html" <content>
-                [ form edit-form ] >>body
-            ] >>display
 
             [
                 blank-values
@@ -174,10 +168,7 @@ SYMBOL: previous-page
                 dup email>> "email" set-value
             ] >>init
 
-            [
+            [ form edit-form ] >>display
-                "text/html" <content>
-                [ form edit-form ] >>body
-            ] >>display
 
             [
                 blank-values
@@ -262,10 +253,7 @@ SYMBOL: lost-password-from
         <action>
             [ blank-values ] >>init
 
-            [
+            [ form edit-form ] >>display
-                "text/html" <content>
-                [ form edit-form ] >>body
-            ] >>display
 
             [
                 blank-values
@@ -314,10 +302,7 @@ SYMBOL: lost-password-from
                 ] H{ } make-assoc values set
             ] >>init
 
-            [
+            [ <recover-form-3> edit-form ] >>display
-                "text/html" <content>
-                [ <recover-form-3> edit-form ] >>body
-            ] >>display
 
             [
                 blank-values

extra/http/server/boilerplate/boilerplate.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces boxes sequences strings
 io io.streams.string
+http
 http.server
 http.server.templating ;
 IN: http.server.boilerplate
@@ -27,6 +28,8 @@ SYMBOL: style
 : write-style ( -- )
     style get >string write ;
 
+SYMBOL: nested-template?
+
 SYMBOL: next-template
 
 : call-next-template ( -- )
@@ -39,9 +42,15 @@ M: f call-template drop call-next-template ;
         title get [ <box> title set ] unless
         style get [ SBUF" " clone style set ] unless
 
-        swap with-string-writer next-template set
+        [
-
+            [
-        call-template
+                nested-template? on
+                write-response-body*
+            ] with-string-writer
+            next-template set
+        ]
+        [ call-template ]
+        bi*
     ] with-scope ; inline
 
 M: boilerplate call-responder

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

@@ -1,12 +1,10 @@
 IN: http.server.components.tests
 USING: http.server.components http.server.forms
 http.server.validators namespaces tools.test kernel accessors
-tuple-syntax mirrors http.server.actions
+tuple-syntax mirrors
-http.server.templating.fhtml
+http http.server.actions http.server.templating.fhtml
 io.streams.string io.streams.null ;
 
-\ render-edit must-infer
-
 validation-failed? off
 
 [ 3 ] [ "3" "n" <number> validate ] unit-test
@@ -65,9 +63,9 @@ TUPLE: test-tuple text number more-text ;
             "hi" >>default
             add-field ;
 
-[ ] [ <test-tuple> <mirror> values set <test-form> view-form ] unit-test
+[ ] [ <test-tuple> <mirror> values set <test-form> view-form write-response-body drop ] unit-test
 
-[ ] [ <test-tuple> <mirror> values set <test-form> edit-form ] unit-test
+[ ] [ <test-tuple> <mirror> values set <test-form> edit-form write-response-body drop ] unit-test
 
 [ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [
     <test-tuple> from-tuple

extra/http/server/components/components.factor

@@ -7,9 +7,12 @@ continuations math ;
 IN: http.server.components
 
 ! Renderer protocol
+GENERIC: render-summary* ( value renderer -- )
 GENERIC: render-view* ( value renderer -- )
 GENERIC: render-edit* ( value id renderer -- )
 
+M: object render-summary* render-view* ;
+
 TUPLE: field type ;
 
 C: <field> field
@@ -235,3 +238,35 @@ TUPLE: text < string ;
 
 : <text> ( id -- component )
     text new-text ;
+
+! List components
+SYMBOL: +plain+
+SYMBOL: +ordered+
+SYMBOL: +unordered+
+
+TUPLE: list-renderer component type ;
+
+C: <list-renderer> list-renderer
+
+: render-list ( value component -- )
+    [ render-summary* ] curry each ;
+
+: render-ordered-list ( value component -- )
+    [ <li> render-summary* </li> ] curry each ;
+
+: render-unordered-list ( value component -- )
+    [ <li> render-summary* </li> ] curry each ;
+
+M: list-renderer render-view*
+    [ component>> ] [ type>> ] bi {
+        { +plain+ [ render-list ] }
+        { +ordered+ [ <ol> render-ordered-list </ol> ] }
+        { +unordered+ [ <ul> render-unordered-list </ul> ] }
+    } case ;
+
+TUPLE: list < component ;
+
+: <list> ( id component type -- list )
+    <list-renderer> list swap new-component ;
+
+M: list component-string drop ;

extra/http/server/crud/crud.factor

@@ -15,10 +15,7 @@ IN: http.server.crud
 
         [ "id" get ctor call select-tuple from-tuple ] >>init
 
-        [
+        [ form view-form ] >>display ;
-            "text/html" <content>
-            [ form view-form ] >>body
-        ] >>display ;
 
 : <id-redirect> ( id next -- response )
     swap number>string "id" associate <permanent-redirect> ;
@@ -36,10 +33,7 @@ IN: http.server.crud
             if
         ] >>init
 
-        [
+        [ form edit-form ] >>display
-            "text/html" <content>
-            [ form edit-form ] >>body
-        ] >>display
 
         [
             f ctor call from-tuple
@@ -64,13 +58,10 @@ IN: http.server.crud
 
 :: <list-action> ( form ctor -- action )
     <action>
-        [
-            "text/html" <content>
         [
             blank-values
 
             f ctor call select-tuples "list" set-value
 
             form view-form
-            ] >>body
         ] >>display ;

extra/http/server/forms/forms.factor

@@ -1,4 +1,7 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors assocs namespaces io.files sequences fry
+http.server
 http.server.actions
 http.server.components
 http.server.validators
@@ -17,8 +20,11 @@ M: form init V{ } clone >>components ;
 : add-field ( form component -- form )
     dup id>> pick components>> set-at ;
 
+: set-components ( form -- )
+    components>> components set ;
+
 : with-form ( form quot -- )
-    >r components>> components r> with-variable ; inline
+    [ [ set-components ] [ call ] bi* ] with-scope ; inline
 
 : set-defaults ( form -- )
     [
@@ -29,14 +35,16 @@ M: form init V{ } clone >>components ;
         ] assoc-each
     ] with-form ;
 
-: view-form ( form -- )
+: <form-response> ( form template -- response )
-    dup view-template>> '[ , call-template ] with-form ;
+    [ components>> components set ]
+    [ "text/html" <content> swap >>body ]
+    bi* ;
 
-: edit-form ( form -- )
+: view-form ( form -- response )
-    dup edit-template>> '[ , call-template ] with-form ;
+    dup view-template>> <form-response> ;
 
-: summary-form ( form -- )
+: edit-form ( form -- response )
-    dup summary-template>> '[ , call-template ] with-form ;
+    dup edit-template>> <form-response> ;
 
 : validate-param ( id component -- )
     [ [ params get at ] [ validate ] bi* ]
@@ -52,19 +60,19 @@ M: form init V{ } clone >>components ;
 : validate-form ( form -- )
     (validate-form) [ validation-failed ] when ;
 
-! List components
+: render-form ( value form template -- )
-TUPLE: list-renderer form ;
+    [
+        [ from-tuple ]
+        [ set-components ]
+        [ call-template ]
+        tri*
+    ] with-scope ;
 
-C: <list-renderer> list-renderer
+M: form render-summary*
+    dup summary-template>> render-form ;
 
-M: list-renderer render-view*
+M: form render-view*
-    form>> [
+    dup view-template>> render-form ;
-        [ >r from-tuple r> summary-form ] with-scope
-    ] curry each ;
 
-TUPLE: list < component ;
+M: form render-edit*
-
+    dup edit-template>> render-form ;
-: <list> ( id form -- list )
-    list swap <list-renderer> new-component ;
-
-M: list component-string drop ;

extra/http/server/templating/chloe/chloe.factor

@@ -156,13 +156,19 @@ SYMBOL: tags
     [
         V{ } clone tags set
 
+        nested-template? get [
+            process-template
+        ] [
             {
                 [ xml-prolog write-prolog ]
                 [ xml-before write-chunk  ]
                 [ process-template        ]
                 [ xml-after write-chunk   ]
             } cleave
+        ] if
     ] with-scope ;
 
 M: chloe call-template
     path>> utf8 <file-reader> read-xml process-chloe ;
+
+INSTANCE: chloe template

extra/http/server/templating/fhtml/fhtml.factor

@@ -94,3 +94,5 @@ M: fhtml call-template ( filename -- )
     [ <fhtml> serve-template ]
     "application/x-factor-server-page"
     pick special>> set-at ;
+
+INSTANCE: fhtml template

extra/http/server/templating/templating.factor

@@ -1,9 +1,13 @@
 USING: accessors kernel fry io.encodings.utf8 io.files
-http.server ;
+http http.server ;
 IN: http.server.templating
 
+MIXIN: template
+
 GENERIC: call-template ( template -- )
 
+M: template write-response-body* call-template ;
+
 : template-convert ( template output -- )
     utf8 [ call-template ] with-file-writer ;
 

extra/webapps/todo/todo.factor

@@ -53,7 +53,7 @@ todo "TODO"
 : <todo-list-form> ( -- form )
     "todo-list" <form>
         "todo-list" todo-template >>view-template
-        "list" <todo-form> <list>
+        "list" <todo-form> +plain+ <list>
         add-field ;
 
 TUPLE: todo-responder < dispatcher ;