Merge branch 'master' into experimental

Conflicts:
	basis/http/client/client.factor

diff --combined basis/http/client/client.factor
index 9c56411290ab4c7b4b9647658958838747a2199d,e7305ed372b96d00023eb40536f948326a338c19..d4d09789121241135a07db213c626402286db432
--- 1/basis/http/client/client.factor
--- 2/basis/http/client/client.factor
+++ b/basis/http/client/client.factor
@@@ -1,20 -1,21 +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 +27,19 @@@
      [ 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 +67,7 @@@
      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
  
@@@ -108,7 -82,7 +82,7 @@@
      redirects get max-redirects < [
          request get clone
          swap "location" header redirect-url
 -        "GET" >>method swap (with-http-request)
 +        "GET" >>method swap with-http-request
      ] [ too-many-redirects ] if ; inline recursive
  
  : read-chunk-size ( -- n )
@@@ -122,23 -96,16 +96,18 @@@
          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
      1 minutes over set-timeout ;
  
 -: (with-http-request) ( request quot: ( chunk -- ) -- response )
 +PRIVATE>
 +
 +: with-http-request ( request quot: ( chunk -- ) -- response )
      swap
      request [
          <request-socket> [
@@@ -160,50 -127,35 +129,57 @@@
          [ 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 ;
 +ERROR: download-failed response data ;
 +
 +M: download-failed error.
 +    "HTTP request failed:" print nl
 +    [ response>> . ] [ data>> . ] bi ;
  
 -: check-response ( response -- response )
 -    dup code>> success? [ download-failed ] unless ;
 +: 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
 -    over content-charset>> decode ;
 +    over content-charset>> decode check-response* ;
 +
 +: <client-request> ( url -- request )
 +    <request> swap >url ensure-port >>url ;
 +
 +: <client-data-request> ( data url -- request )
 +    <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 ;
  
  : with-http-get ( url quot -- response )
 -    [ <get-request> ] dip with-http-request ; inline
 +    [ <get-request> ] dip with-http-request check-response ; inline
 +
 +: <delete-request> ( url -- request )
 +    <client-request> "DELETE" >>method ;
 +
 +: http-delete ( url -- response data )
 +    <delete-request> http-request ;
 +
 +: <trace-request> ( url -- request )
 +    <client-request> "TRACE" >>method ;
 +
 +: http-trace ( url -- response data )
 +    <trace-request> http-request ;
  
  : download-name ( url -- name )
      present file-name "?" split1 drop "/" ?tail drop ;
@@@ -215,15 -167,17 +191,17 @@@
      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 ;