Merge branch 'master' into experimental (untested!)

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

diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor
index 108ae5ecc4c28bbbea3f2441288f8ff48fc09088..9c56411290ab4c7b4b9647658958838747a2199d 100644 (file)
--- a/basis/http/client/client.factor
+++ b/basis/http/client/client.factor
@@ -53,7 +53,8 @@ M: f >post-data ;
     [ >post-data ] change-post-data ;
 
 : write-post-data ( request -- request )
-    dup method>> [ "POST" = ] [ "PUT" = ] bi or [ dup post-data>> raw>> write ] when ; 
+    dup method>> [ "POST" = ] [ "PUT" = ] bi or
+    [ dup post-data>> [ raw>> write ] when* ] when ; 
 
 : write-request ( request -- )
     unparse-post-data
@@ -86,9 +87,13 @@ M: f >post-data ;
 
 ERROR: too-many-redirects ;
 
-<PRIVATE
+M: too-many-redirects summary
+    drop
+    [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
+
+DEFER: with-http-request
 
-DEFER: (with-http-request)
+<PRIVATE
 
 SYMBOL: redirects
 
@@ -103,7 +108,7 @@ SYMBOL: redirects
     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 )
@@ -131,7 +136,9 @@ SYMBOL: redirects
     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> [
@@ -153,32 +160,50 @@ SYMBOL: redirects
         [ do-redirect ] [ nip ] if
     ] with-variable ; inline recursive
 
-PRIVATE>
-
 : success? ( code -- ? ) 200 299 between? ;
 
-ERROR: download-failed response ;
+ERROR: download-failed response data ;
 
-: check-response ( response -- response )
-    dup code>> success? [ download-failed ] unless ;
+M: download-failed error.
+    "HTTP request failed:" print nl
+    [ response>> . ] [ data>> . ] bi ;
+
+: check-response* ( response data -- response data )
+    over code>> success? [ download-failed ] unless ;
 
-: with-http-request ( request quot -- response )
-    (with-http-request) check-response ; inline
+: check-response ( response -- response )
+    f check-response* drop ;
 
 : 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 )
-    <request>
-        "GET" >>method
-        swap >url ensure-port >>url ;
+    <client-request> "GET" >>method ;
 
 : 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 ;
@@ -190,14 +215,17 @@ ERROR: download-failed response ;
     dup download-name download-to ;
 
 : <post-request> ( post-data url -- request )
-    <request>
-        "POST" >>method
-        swap >url ensure-port >>url
-        swap >>post-data ;
+    <client-data-request> "POST" >>method ;
 
 : http-post ( post-data url -- response data )
     <post-request> http-request ;
 
+: <put-request> ( data url -- request )
+    <client-data-request> "PUT" >>method ;
+
+: http-put ( data url -- response data )
+    <put-request> http-request ;
+
 USING: vocabs vocabs.loader ;
 
 "debugger" vocab [ "http.client.debugger" require ] when