From 1cf1d967ea7352870d57b951f8d68f21b2e53002 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Oct 2008 05:43:20 -0500 Subject: [PATCH] New combinators for incremental HTTP requests --- basis/http/client/client-docs.factor | 15 +++- basis/http/client/client-tests.factor | 3 + basis/http/client/client.factor | 114 +++++++++++++++----------- 3 files changed, 84 insertions(+), 48 deletions(-) diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index ed846320c3..a762d1a5ef 100644 --- a/basis/http/client/client-docs.factor +++ b/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 } -{ $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 } ":" diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor index 1219ae0b97..4dcc6b8813 100755 --- a/basis/http/client/client-tests.factor +++ b/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 diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 174c4e1b3a..aa1e0771ba 100755 --- a/basis/http/client/client.factor +++ b/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) - 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 ; + [ 2drop ] [ + read [ swap call ] [ drop ] 2bi + read-crlf B{ } assert= read-chunked + ] if ; inline recursive -: 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 ; +: read-unchunked ( quot: ( chunk -- ) -- ) + 8192 read dup [ + [ swap call ] [ drop read-unchunked ] 2bi + ] [ 2drop ] if ; inline recursive -: (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 ; +: read-response-body ( quot response -- ) + binary decode-input + "transfer-encoding" header "chunked" = + [ read-chunked ] [ read-unchunked ] if ; inline + +: ( -- stream ) + request get url>> url-addr ascii drop + 1 minutes over set-timeout ; + +: (with-http-request) ( request quot: ( chunk -- ) -- response ) + swap + request [ + [ + [ + 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 - [ response>> . nl ] [ body>> write ] bi ; + "HTTP request failed:" print nl + response>> . ; -: check-response ( response data -- response data ) - over code>> success? [ download-failed ] unless ; +: check-response ( response -- response ) + 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 ; : ( url -- request ) @@ -163,14 +183,14 @@ M: download-failed error. : http-get ( url -- response data ) http-request ; +: with-http-get ( url quot -- response ) + [ ] 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 ;