New combinators for incremental HTTP requests

basis/http/client/client-docs.factor

@@ -39,11 +39,21 @@ HELP: http-post
 { $description "Submits a form at a URL." }
 { $errors "Throws an error if the HTTP request fails." } ;
 
+HELP: with-http-get
+{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } }
+{ $description "Downloads the contents of a URL. Chunks of data are passed to the quotation as they are read." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
 HELP: http-request
 { $values { "request" request } { "response" response } { "data" sequence } }
 { $description "Sends an HTTP request to an HTTP server, and reads the response." }
 { $errors "Throws an error if the HTTP request fails." } ;
 
+HELP: with-http-request
+{ $values { "request" request } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } }
+{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
 ARTICLE: "http.client.get" "GET requests with the HTTP client"
 "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"
 { $subsection http-get }
@@ -52,7 +62,10 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client"
 { $subsection download-to }
 "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:"
 { $subsection <get-request> }
-{ $subsection http-request } ;
+{ $subsection http-request }
+"The " { $link http-get } " and " { $link http-request } " words output sequences. This is undesirable if the response data may be large. Another pair of words take a quotation instead, and pass the quotation chunks of data incrementally:"
+{ $subsection with-http-get }
+{ $subsection with-http-request } ;
 
 ARTICLE: "http.client.post" "POST requests with the HTTP client"
 "As with GET requests, there is a high-level word which takes a " { $link url } " and a lower-level word which constructs an HTTP request object which can be passed to " { $link http-request } ":"

basis/http/client/client-tests.factor

@@ -1,5 +1,8 @@
 USING: http.client http.client.private http tools.test
 namespaces urls ;
+
+\ download must-infer
+
 [ "localhost" f ] [ "localhost" parse-host ] unit-test
 [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
 

basis/http/client/client.factor

@@ -3,7 +3,7 @@
 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
@@ -88,72 +88,92 @@ M: too-many-redirects summary
     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 )
+: redirect? ( response -- ? )
-    over code>> 300 399 between? [
+    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 ;
 
-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 ;
+    [ 2drop ] [
+        read [ swap call ] [ drop ] 2bi
+        read-crlf B{ } assert= read-chunked
+    ] if ; inline recursive
 
-: read-response-body ( response -- response data )
+: read-unchunked ( quot: ( chunk -- ) -- )
-    dup "transfer-encoding" header "chunked" = [
+    8192 read dup [
-        binary decode-input
+        [ swap call ] [ drop read-unchunked ] 2bi
-        [ read-chunks ] B{ } make
+    ] [ 2drop ] if ; inline recursive
-        over content-charset>> decode
-    ] [
-        dup content-charset>> decode-input
-        input-stream get contents
-    ] if ;
 
-: (http-request) ( request -- response data )
+: read-response-body ( quot response -- )
-    dup request [
+    binary decode-input
-        dup url>> url-addr ascii [
+    "transfer-encoding" header "chunked" =
-            1 minutes timeouts
+    [ read-chunked ] [ read-unchunked ] if ; inline
-            write-request
+
-            read-response
+: <request-socket> ( -- stream )
-            read-response-body
+    request get url>> url-addr ascii <client> drop
-        ] with-client
+    1 minutes over set-timeout ;
-        do-redirect
+
-    ] with-variable ;
+: (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 = ;
 
-ERROR: download-failed response body ;
+ERROR: download-failed response ;
 
 M: download-failed error.
-    "HTTP download failed:" print nl
+    "HTTP request failed:" print nl
-    [ response>> . nl ] [ body>> write ] bi ;
+    response>> . ;
 
-: check-response ( response data -- response data )
+: check-response ( response -- response )
-    over code>> success? [ download-failed ] unless ;
+    dup 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 @@ M: download-failed error.
 : 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.
+    binary [ [ write ] with-http-get drop ] with-file-writer ;
-    swap http-get
-    [ content-charset>> ] [ '[ _ write ] ] bi*
-    with-file-writer ;
 
 : download ( url -- )
     dup download-name download-to ;