Fix information leakage

extra/http/http-tests.factor

@@ -276,3 +276,7 @@ SYMBOL: a
 [ 4 ] [ a get-global ] unit-test
 
 [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
+
+! Test cloning
+[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
+[ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test

extra/http/http.factor

@@ -6,7 +6,8 @@ assocs sequences splitting sorting sets debugger
 strings vectors hashtables quotations arrays byte-arrays
 math.parser calendar calendar.format present
 
-io io.encodings.iana io.encodings.binary io.encodings.8-bit
+io io.encodings io.encodings.iana io.encodings.binary
+io.encodings.8-bit
 
 unicode.case unicode.categories qualified
 
@@ -298,6 +299,11 @@ body ;
         latin1 >>content-charset
         V{ } clone >>cookies ;
 
+M: response clone
+    call-next-method
+        [ clone ] change-header
+        [ clone ] change-cookies ;
+
 : read-response-version ( response -- response )
     " \t" read-until
     [ "Bad response: version" throw ] unless
@@ -363,7 +369,11 @@ M: response write-response ( respose -- )
 
 M: response write-full-response ( request response -- )
     dup write-response
-    swap method>> "HEAD" = [ write-response-body ] unless ;
+    swap method>> "HEAD" = [
+        [ content-charset>> encode-output ]
+        [ write-response-body ]
+        bi
+    ] unless ;
 
 : get-cookie ( request/response name -- cookie/f )
     [ cookies>> ] dip '[ , _ name>> = ] find nip ;

extra/http/server/server.factor

@@ -60,23 +60,16 @@ main-responder global [ <404> <trivial-responder> or ] change-at
     swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ;
 
 : do-response ( response -- )
-    [ write-response ]
+    [ request get swap write-full-response ]
     [
-        request get method>> "HEAD" = [ drop ] [
-            '[
-                ,
-                [ content-charset>> encode-output ]
-                [ write-response-body ]
-                bi
-            ]
+        [ \ do-response log-error ]
         [
             utf8 [
                 development? get
-                    [ http-error. ] [ drop "Response error" rethrow ] if
+                [ http-error. ] [ drop "Response error" write ] if
             ] with-encoded-output
-            ] recover
-        ] if
-    ] bi ;
+        ] bi
+    ] recover ;
 
 LOG: httpd-hit NOTICE