add support for redirections to get-pure-port and add get-pure-port/headers

original commit: 11a3d9b0ac

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?)]

collects/tests/net/url-port.rkt

@@ -4,38 +4,48 @@
          openssl
          tests/eli-tester)
 
-(define (run-tests scheme wrap-ports)
+(define (run-tests scheme wrap-ports skip-actual-redirect?)
-  (define ((make-tester url->port) response)
+  (define ((make-tester url->port) response . responses)
-    (define port-no 9001)
+    (define first-port-no 9001)
     (define server-cust
       (make-custodian))
     (parameterize ([current-custodian server-cust])
-      (thread 
+      (for ([response (in-list (cons response responses))]
-       (λ ()
+            [port-no (in-naturals first-port-no)])
-          (run-server port-no 
+        (thread 
-                      (lambda (ip op)
+         (λ ()
-                        (let-values ([(ip op) (wrap-ports ip op)])
+           (run-server port-no 
-                          (regexp-match #rx"(\r\n|^)\r\n" ip)
+                       (lambda (ip op)
-                          (display response op)
+                         (let-values ([(ip op) (wrap-ports ip op)])
-                          (close-output-port op)
+                           (regexp-match #rx"(\r\n|^)\r\n" ip)
-                          (close-input-port ip)))
+                           (display response op)
-                      +inf.0))))
+                           (close-output-port op)
+                           (close-input-port ip)))
+                       +inf.0)))))
     (sleep 1)
     (dynamic-wind
-        void
+     void
+     (λ ()
+       (call-with-values
         (λ ()
-           (port->string
+          (url->port
-            (url->port
+           (url scheme #f "localhost" first-port-no
-             (url scheme #f "localhost" port-no
+                #t empty empty #f)))
-                  #t empty empty #f))))
+        (λ vals (apply values (cons (port->string (car vals)) (cdr vals))))))
-        (λ ()
+     (λ ()
-           (custodian-shutdown-all server-cust))))  
+       (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
+   (get-pure/redirect
-    "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")
+    "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)