Merge branch 'master' into experimental

[factor.git] / basis / http / client / client.factor

diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor
index 9c56411290ab4c7b4b9647658958838747a2199d..d4d09789121241135a07db213c626402286db432 100644 (file)
--- a/basis/http/client/client.factor
+++ b/basis/http/client/client.factor
@@ -1,20 +1,21 @@
-! 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 io io.sockets io.streams.string io.files io.timeouts
-strings splitting calendar continuations accessors vectors
+sequences strings splitting calendar continuations accessors vectors
 math.order hashtables byte-arrays destructors
-io.encodings
-io.encodings.string
-io.encodings.ascii
-io.encodings.utf8
-io.encodings.8-bit
-io.encodings.binary
-io.streams.duplex
-fry ascii urls urls.encoding present
-http http.parsers ;
+io io.sockets io.streams.string io.files io.timeouts
+io.pathnames io.encodings io.encodings.string io.encodings.ascii
+io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf
+io.streams.duplex fry ascii urls urls.encoding present
+http http.parsers http.client.post-data ;
 IN: http.client
 
+ERROR: too-many-redirects ;
+
+CONSTANT: max-redirects 10
+
+<PRIVATE
+
 : write-request-line ( request -- request )
     dup
     [ method>> write bl ]
@@ -26,36 +27,19 @@ IN: http.client
     [ host>> ] [ port>> ] bi dup "http" protocol-port =
     [ drop ] [ ":" swap number>string 3append ] if ;
 
+: 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 post-data>> [
-        [ raw>> length "content-length" pick set-at ]
-        [ content-type>> "content-type" pick set-at ]
-        bi
-    ] when*
-    over cookies>> [ unparse-cookie "cookie" pick set-at ] unless-empty
+    over url>> host>> [ set-host-header ] when
+    over post-data>> [ set-post-data-headers ] when*
+    over cookies>> [ set-cookie-header ] unless-empty
     write-header ;
 
-GENERIC: >post-data ( object -- post-data )
-
-M: post-data >post-data ;
-
-M: string >post-data utf8 encode "application/octet-stream" <post-data> ;
-
-M: byte-array >post-data "application/octet-stream" <post-data> ;
-
-M: assoc >post-data assoc>query ascii encode "application/x-www-form-urlencoded" <post-data> ;
-
-M: f >post-data ;
-
-: unparse-post-data ( request -- request )
-    [ >post-data ] change-post-data ;
-
-: write-post-data ( request -- request )
-    dup method>> [ "POST" = ] [ "PUT" = ] bi or
-    [ dup post-data>> [ raw>> write ] when* ] when ; 
-
 : write-request ( request -- )
     unparse-post-data
     write-request-line
@@ -83,17 +67,7 @@ M: f >post-data ;
     read-response-line
     read-response-header ;
 
-: max-redirects 10 ;
-
-ERROR: too-many-redirects ;
-
-M: too-many-redirects summary
-    drop
-    [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
-
-DEFER: with-http-request
-
-<PRIVATE
+DEFER: (with-http-request)
 
 SYMBOL: redirects
 
@@ -122,15 +96,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
@@ -160,6 +129,13 @@ PRIVATE>
         [ 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? ;
 
 ERROR: download-failed response data ;
@@ -171,8 +147,8 @@ M: download-failed error.
 : check-response* ( response data -- response data )
     over code>> success? [ download-failed ] unless ;
 
-: check-response ( response -- response )
-    f check-response* drop ;
+: with-http-request ( request quot -- response )
+    [ (with-http-request) check-response ] with-destructors ; inline
 
 : http-request ( request -- response data )
     [ [ % ] with-http-request ] B{ } make
@@ -185,7 +161,7 @@ M: download-failed error.
     <client-request> swap >>post-data ;
 
 : <get-request> ( url -- request )
-    <client-request> "GET" >>method ;
+    "GET" <client-request> ;
 
 : http-get ( url -- response data )
     <get-request> http-request ;
@@ -215,15 +191,17 @@ M: download-failed error.
     dup download-name download-to ;
 
 : <post-request> ( post-data url -- request )
-    <client-data-request> "POST" >>method ;
+    "POST" <client-request>
+        swap >>post-data ;
 
 : http-post ( post-data url -- response data )
     <post-request> http-request ;
 
-: <put-request> ( data url -- request )
-    <client-data-request> "PUT" >>method ;
+: <put-request> ( post-data url -- request )
+    "PUT" <client-request>
+        swap >>post-data ;
 
-: http-put ( data url -- response data )
+: http-put ( post-data url -- response data )
     <put-request> http-request ;
 
 USING: vocabs vocabs.loader ;