diff --git a/collects/net/scribblings/url.scrbl b/collects/net/scribblings/url.scrbl index e1b2db5f32..0ed9d25aad 100644 --- a/collects/net/scribblings/url.scrbl +++ b/collects/net/scribblings/url.scrbl @@ -188,7 +188,8 @@ Determines the default conversion to and from strings for @deftogether[( @defproc[(get-pure-port [URL url?] - [header (listof string?) null]) + [header (listof string?) null] + [#:redirections redirections exact-nonnegative-integer? 0]) input-port?] @defproc[(head-pure-port [URL url?] [header (listof string?) null]) @@ -204,7 +205,9 @@ optional list of strings can be used to send header lines to the server. The GET method is used to retrieve whatever information is identified -by @racket[URL]. +by @racket[URL]. If @racket[redirections] is not @racket[0], then +@racket[get-pure-port] will follow redirections from the server, +up to the limit given by @racket[redirections]. The HEAD method is identical to GET, except the server must not return a message body. The meta-information returned in a response to a HEAD @@ -304,6 +307,18 @@ empty string, or it will be a string matching the following regexp: #rx"^HTTP/.*?(\r\n\r\n|\n\n|\r\r)" ]} +@defproc[(get-pure-port/headers + [url url?] + [headers (listof string?) '()] + [#:redirections redirections exact-nonnegative-integer? 0]) + (values input-port? string?)]{ + This function is an alternative to calling @racket[get-impure-port] and + @racket[purify-port] when needing to follow redirections. + + That is, it does a GET request on @racket[url], follows up to + @racket[redirections] redirections and returns a port containing + the data as well as the headers for the final connection. +} @defproc*[([(call/input-url [URL url?] [connect (url? . -> . input-port?)] diff --git a/collects/tests/net/url-port.rkt b/collects/tests/net/url-port.rkt index d7e4cdda9e..3b0a48e5e4 100644 --- a/collects/tests/net/url-port.rkt +++ b/collects/tests/net/url-port.rkt @@ -4,38 +4,48 @@ openssl tests/eli-tester) -(define (run-tests scheme wrap-ports) - (define ((make-tester url->port) response) - (define port-no 9001) +(define (run-tests scheme wrap-ports skip-actual-redirect?) + (define ((make-tester url->port) response . responses) + (define first-port-no 9001) (define server-cust (make-custodian)) (parameterize ([current-custodian server-cust]) - (thread - (λ () - (run-server port-no - (lambda (ip op) - (let-values ([(ip op) (wrap-ports ip op)]) - (regexp-match #rx"(\r\n|^)\r\n" ip) - (display response op) - (close-output-port op) - (close-input-port ip))) - +inf.0)))) + (for ([response (in-list (cons response responses))] + [port-no (in-naturals first-port-no)]) + (thread + (λ () + (run-server port-no + (lambda (ip op) + (let-values ([(ip op) (wrap-ports ip op)]) + (regexp-match #rx"(\r\n|^)\r\n" ip) + (display response op) + (close-output-port op) + (close-input-port ip))) + +inf.0))))) (sleep 1) (dynamic-wind - void + void + (λ () + (call-with-values (λ () - (port->string - (url->port - (url scheme #f "localhost" port-no - #t empty empty #f)))) - (λ () - (custodian-shutdown-all server-cust)))) + (url->port + (url scheme #f "localhost" first-port-no + #t empty empty #f))) + (λ vals (apply values (cons (port->string (car vals)) (cdr vals)))))) + (λ () + (custodian-shutdown-all server-cust)))) (define get-pure (make-tester get-pure-port)) (define get-impure (make-tester get-impure-port)) - + (define get-pure/redirect + (make-tester (λ (x) (get-pure-port x #:redirections 1)))) + (define get-pure/headers + (make-tester get-pure-port/headers)) + (define get-pure/headers/redirect + (make-tester (λ (x) (get-pure-port/headers x #:redirections 1)))) + (test (get-pure "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n24\r\nThis is the data in the first chunk \r\n1A\r\nand this is the second one\r\n0\r\n") @@ -52,21 +62,70 @@ => "This is the data in the first chand this is the second oneXXXXXXX" - (get-impure - "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n23\r\nThis is the data in the first chunk\r\n1A\r\nand this is the second one\r\n0\r\n") + (get-pure/redirect + "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n24\r\nThis is the data in the first chunk \r\n1A\r\nand this is the second one\r\n0\r\n") => - "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n23\r\nThis is the data in the first chunk\r\n1A\r\nand this is the second one\r\n0\r\n" + "This is the data in the first chunk and this is the second one" + (get-pure/redirect + "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one") + => + "This is the data in the first chunk and this is the second one" + + (get-pure/redirect + "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n") + => + "This is the data in the first chand this is the second oneXXXXXXX" + (get-impure "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one\r\n") => "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one\r\n" - )) + + (get-pure/headers + "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n24\r\nThis is the data in the first chunk \r\n1A\r\nand this is the second one\r\n0\r\n") + => + (values "This is the data in the first chunk and this is the second one" + "Content-Type: text/plain\r\nTransfer-Encoding: chunked\r\n") + + (get-pure/headers + "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one") + => + (values "This is the data in the first chunk and this is the second one" + "Content-Type: text/plain\r\n") + + (get-pure/headers + "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n") + => + (values "This is the data in the first chand this is the second oneXXXXXXX" + "Content-Type: text/plain\r\nTransfer-Encoding: chunked\r\n") + + (get-pure/headers + "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\nAnother-Header: ta-daa\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n") + => + (values "This is the data in the first chand this is the second oneXXXXXXX" + "Content-Type: text/plain\r\nTransfer-Encoding: chunked\r\nAnother-Header: ta-daa\r\n") + ) + + (unless skip-actual-redirect? + (test + (get-pure/redirect + "HTTP/1.1 301 Moved Permanently\r\nLocation: http://localhost:9002/whatever\r\n\r\nstuff" + (string-append + "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n" + "24\r\nThis is the data in the first chunk \r\n1A\r\nand this is the second one\r\n0\r\n")) + + (get-pure/headers/redirect + "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\nAnother-Header: ta-daa\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n") + => + (values "This is the data in the first chand this is the second oneXXXXXXX" + "Content-Type: text/plain\r\nTransfer-Encoding: chunked\r\nAnother-Header: ta-daa\r\n")))) -(run-tests "http" values) +(run-tests "http" values #f) (run-tests "https" (let ([ctx (ssl-make-server-context)]) (ssl-load-certificate-chain! ctx (collection-file-path "test.pem" "openssl")) (ssl-load-private-key! ctx (collection-file-path "test.pem" "openssl")) (lambda (in out) - (ports->ssl-ports in out #:mode 'accept #:context ctx)))) + (ports->ssl-ports in out #:mode 'accept #:context ctx))) + #t)