Fix POST with streams to use chunked encoding, add http-put word

basis/http/client/client.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs kernel math math.parser namespaces make
 sequences strings splitting calendar continuations accessors vectors
@@ -10,6 +10,12 @@ io.streams.duplex fry ascii urls urls.encoding present
 http http.parsers ;
 IN: http.client
 
+ERROR: too-many-redirects ;
+
+CONSTANT: max-redirects 10
+
+<PRIVATE
+
 : write-request-line ( request -- request )
     dup
     [ method>> write bl ]
@@ -21,17 +27,29 @@ IN: http.client
     [ host>> ] [ port>> ] bi dup "http" protocol-port =
     [ drop ] [ ":" swap number>string 3append ] if ;
 
+: set-post-data-headers ( header post-data -- header )
+    [
+        data>> dup sequence?
+        [ length "content-length" ]
+        [ drop "chunked" "transfer-encoding" ] if
+        pick set-at
+    ] [ content-type>> "content-type" pick set-at ] bi ;
+
+: set-host-header ( request header -- request header )
+    over url>> url-host "host" pick set-at ;
+
+: set-cookie-header ( header cookies -- header )
+    unparse-cookie "cookie" pick set-at ;
+
 : write-request-header ( request -- request )
     dup header>> >hashtable
-    over url>> host>> [ over url>> url-host "host" pick set-at ] when
+    over url>> host>> [ set-host-header ] when
-    over post-data>> [
+    over post-data>> [ set-post-data-headers ] when*
-        [ data>> length "content-length" pick set-at ]
+    over cookies>> [ set-cookie-header ] unless-empty
-        [ content-type>> "content-type" pick set-at ]
-        bi
-    ] when*
-    over cookies>> [ unparse-cookie "cookie" pick set-at ] unless-empty
     write-header ;
 
+PRIVATE>
+
 GENERIC: >post-data ( object -- post-data )
 
 M: f >post-data ;
@@ -51,6 +69,8 @@ M: object >post-data
     "application/octet-stream" <post-data>
         swap >>data ;
 
+<PRIVATE
+    
 : normalize-post-data ( request -- request )
     dup post-data>> [
         dup params>> [
@@ -62,11 +82,18 @@ M: object >post-data
     [ >post-data ] change-post-data
     normalize-post-data ;
 
+: write-chunk ( chunk -- )
+    [ length >hex ";\r\n" append ascii encode write ] [ write ] bi ;
+
+: write-chunked ( stream -- )
+    [ [ write-chunk ] each-block ] with-input-stream
+    "0;\r\n" ascii encode write ;
+
 : write-post-data ( request -- request )
     dup method>> { "POST" "PUT" } member?  [
         dup post-data>> data>> dup sequence?
-        [ write ] [ output-stream get stream-copy ] if
+        [ write ] [ write-chunked ] if
-    ] when ; 
+    ] when ;
 
 : write-request ( request -- )
     unparse-post-data
@@ -95,12 +122,6 @@ M: object >post-data
     read-response-line
     read-response-header ;
 
-: max-redirects 10 ;
-
-ERROR: too-many-redirects ;
-
-<PRIVATE
-
 DEFER: (with-http-request)
 
 SYMBOL: redirects
@@ -130,15 +151,10 @@ SYMBOL: redirects
         read-crlf B{ } assert= read-chunked
     ] if ; inline recursive
 
-: read-unchunked ( quot: ( chunk -- ) -- )
-    8192 read-partial dup [
-        [ swap call ] [ drop read-unchunked ] 2bi
-    ] [ 2drop ] if ; inline recursive
-
 : read-response-body ( quot response -- )
     binary decode-input
     "transfer-encoding" header "chunked" =
-    [ read-chunked ] [ read-unchunked ] if ; inline
+    [ read-chunked ] [ each-block ] if ; inline
 
 : <request-socket> ( -- stream )
     request get url>> url-addr ascii <client> drop
@@ -166,6 +182,11 @@ SYMBOL: redirects
         [ do-redirect ] [ nip ] if
     ] with-variable ; inline recursive
 
+: <client-request> ( url method -- request )
+    <request>
+        swap >>method
+        swap >url ensure-port >>url ; inline
+
 PRIVATE>
 
 : success? ( code -- ? ) 200 299 between? ;
@@ -183,9 +204,7 @@ ERROR: download-failed response ;
     over content-charset>> decode ;
 
 : <get-request> ( url -- request )
-    <request>
+    "GET" <client-request> ;
-        "GET" >>method
-        swap >url ensure-port >>url ;
 
 : http-get ( url -- response data )
     <get-request> http-request ;
@@ -203,14 +222,19 @@ ERROR: download-failed response ;
     dup download-name download-to ;
 
 : <post-request> ( post-data url -- request )
-    <request>
+    "POST" <client-request>
-        "POST" >>method
-        swap >url ensure-port >>url
         swap >>post-data ;
 
 : http-post ( post-data url -- response data )
     <post-request> http-request ;
 
+: <put-request> ( post-data url -- request )
+    "PUT" <client-request>
+        swap >>post-data ;
+
+: http-put ( post-data url -- response data )
+    <put-request> http-request ;
+
 USING: vocabs vocabs.loader ;
 
 "debugger" vocab [ "http.client.debugger" require ] when

basis/http/http-tests.factor

@@ -1,4 +1,4 @@
-USING: http http.server http.client tools.test multiline
+USING: http http.server http.client http.client.private tools.test multiline
 io.streams.string io.encodings.utf8 io.encodings.8-bit
 io.encodings.binary io.encodings.string kernel arrays splitting
 sequences assocs io.sockets db db.sqlite continuations urls

basis/http/server/cgi/cgi.factor

@@ -55,7 +55,7 @@ IN: http.server.cgi
         binary encode-output
         _ output-stream get swap <cgi-process> binary <process-stream> [
             post-request? [ request get post-data>> data>> write flush ] when
-            input-stream get swap (stream-copy)
+            '[ _ write ] each-block
         ] with-stream
     ] >>body ;
 

basis/http/server/server.factor

@@ -26,8 +26,6 @@ html.elements
 html.streams ;
 IN: http.server
 
-\ parse-cookie DEBUG add-input-logging
-
 : check-absolute ( url -- url )
     dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline