Merge branch 'experimental' into couchdb

diff --combined basis/http/client/client.factor
index d684d5af9212eae2e9143f38ba7755a28584f697,aa1e0771ba76db6b0e4f504cc3724b4bce78de5b..7fdc9bf5c9c95034510a6054271139b43d798288
--- 1/basis/http/client/client.factor
--- 2/basis/http/client/client.factor
+++ b/basis/http/client/client.factor
@@@ -3,14 -3,14 +3,14 @@@
  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
- math.order hashtables byte-arrays prettyprint
+ math.order hashtables byte-arrays prettyprint destructors
  io.encodings
  io.encodings.string
  io.encodings.ascii
  io.encodings.8-bit
  io.encodings.binary
  io.streams.duplex
- fry debugger summary ascii urls present
+ fry debugger summary ascii urls urls.encoding present
  http http.parsers ;
  IN: http.client
  
@@@ -33,7 -33,7 +33,7 @@@
          [ content-type>> "content-type" pick set-at ]
          bi
      ] when*
-     over cookies>> f like [ unparse-cookie "cookie" pick set-at ] when*
+     over cookies>> [ unparse-cookie "cookie" pick set-at ] unless-empty
      write-header ;
  
  GENERIC: >post-data ( object -- post-data )
@@@ -88,72 -88,92 +88,92 @@@ M: too-many-redirects summar
      drop
      [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
  
- DEFER: (http-request)
- 
  <PRIVATE
  
+ DEFER: (with-http-request)
+ 
  SYMBOL: redirects
  
  : redirect-url ( request url -- request )
      '[ _ >url derive-url ensure-port ] change-url ;
  
- : do-redirect ( response data -- response data )
-     over code>> 300 399 between? [
-         drop
-         redirects inc
-         redirects get max-redirects < [
-             request get
-             swap "location" header redirect-url
-             "GET" >>method (http-request)
-         ] [
-             too-many-redirects
-         ] if
-     ] when ;
+ : redirect? ( response -- ? )
+     code>> 300 399 between? ;
  
- PRIVATE>
+ : do-redirect ( quot: ( chunk -- ) response -- response )
+     redirects inc
+     redirects get max-redirects < [
+         request get clone
+         swap "location" header redirect-url
+         "GET" >>method swap (with-http-request)
+     ] [ too-many-redirects ] if ; inline recursive
  
  : read-chunk-size ( -- n )
      read-crlf ";" split1 drop [ blank? ] trim-right
      hex> [ "Bad chunk size" throw ] unless* ;
  
- : read-chunks ( -- )
+ : read-chunked ( quot: ( chunk -- ) -- )
      read-chunk-size dup zero?
-     [ drop ] [ read % read-crlf B{ } assert= read-chunks ] if ;
- 
- : read-response-body ( response -- response data )
-     dup "transfer-encoding" header "chunked" = [
-         binary decode-input
-         [ read-chunks ] B{ } make
-         over content-charset>> decode
-     ] [
-         dup content-charset>> decode-input
-         input-stream get contents
-     ] if ;
- 
- : (http-request) ( request -- response data )
-     dup request [
-         dup url>> url-addr ascii [
-             1 minutes timeouts
-             write-request
-             read-response
-             read-response-body
-         ] with-client
-         do-redirect
-     ] with-variable ;
+     [ 2drop ] [
+         read [ swap call ] [ drop ] 2bi
+         read-crlf B{ } assert= read-chunked
+     ] if ; inline recursive
+ 
+ : read-unchunked ( quot: ( chunk -- ) -- )
+     8192 read 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
+ 
+ : <request-socket> ( -- stream )
+     request get url>> url-addr ascii <client> drop
+     1 minutes over set-timeout ;
+ 
+ : (with-http-request) ( request quot: ( chunk -- ) -- response )
+     swap
+     request [
+         <request-socket> [
+             [
+                 out>>
+                 [ request get write-request ]
+                 with-output-stream*
+             ] [
+                 in>> [
+                     read-response dup redirect? [ t ] [
+                         [ nip response set ]
+                         [ read-response-body ]
+                         [ ]
+                         2tri f
+                     ] if
+                 ] with-input-stream*
+             ] bi
+         ] with-disposal
+         [ do-redirect ] [ nip ] if
+     ] with-variable ; inline recursive
+ 
+ PRIVATE>
  
 -: success? ( code -- ? ) 200 = ;
 +: success? ( code -- ? ) 200 299 between? ;
  
- ERROR: download-failed response body ;
+ ERROR: download-failed response ;
  
  M: download-failed error.
-     "HTTP download failed:" print nl
-     [ response>> . nl ] [ body>> write ] bi ;
+     "HTTP request failed:" print nl
+     response>> . ;
+ 
+ : check-response ( response -- response )
+     dup code>> success? [ download-failed ] unless ;
  
- : check-response ( response data -- response data )
-     over code>> success? [ download-failed ] unless ;
+ : with-http-request ( request quot -- response )
+     (with-http-request) check-response ; inline
  
  : http-request ( request -- response data )
-     (http-request) check-response ;
+     [ [ % ] with-http-request ] B{ } make
+     over content-charset>> decode ;
  
  : <get-request> ( url -- request )
      <request>
@@@ -163,14 -183,14 +183,14 @@@
  : http-get ( url -- response data )
      <get-request> http-request ;
  
+ : with-http-get ( url quot -- response )
+     [ <get-request> ] dip with-http-request ; inline
+ 
  : download-name ( url -- name )
      present file-name "?" split1 drop "/" ?tail drop ;
  
  : download-to ( url file -- )
-     #! Downloads the contents of a URL to a file.
-     swap http-get
-     [ content-charset>> ] [ '[ _ write ] ] bi*
-     with-file-writer ;
+     binary [ [ write ] with-http-get drop ] with-file-writer ;
  
  : download ( url -- )
      dup download-name download-to ;
@@@ -183,9 -203,3 +203,9 @@@
  
  : http-post ( post-data url -- response data )
      <post-request> http-request ;
 +
 +: <put-request> ( data url -- request )
 +    <post-request> "PUT" >>method ;
 +
 +: http-put ( data url -- response data )
 +    <put-request> http-request ;