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

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/net/url.rkt

@@ -191,20 +191,58 @@
            (schemeless-url url)]
           [(or (string=? scheme "http")
                (string=? scheme "https"))
-           (let loop ([redirections redirections])
+           (cond
-             (cond
+             [(or (not get?) 
-               [(zero? redirections)
+                  ;; do not follow redirections for POST
-                (let ([port (http://getpost-impure-port
+                  (zero? redirections))
-                             get? url post-data strings)])
+              (let ([port (http://getpost-impure-port
-                  (purify-http-port port))]
+                           get? url post-data strings)])
-               [else
+                (purify-http-port port))]
-                (let ([port (http://getpost-impure-port
+             [else
-                             get? url post-data strings)])
+              (define-values (port header) 
-                  (purify-http-port port))]))]
+                (get-pure-port/headers url strings #:redirections redirections))
+              port])]
           [(string=? scheme "file")
            (file://get-pure-port url)]
           [else (url-error "Scheme ~a unsupported" scheme)])))
 
+(define (get-pure-port/headers url [strings '()] #:redirections [redirections 0])
+  (let redirection-loop ([redirections redirections] [url url])
+    (define ip
+      (http://getpost-impure-port #t url #f '()))
+    (define status (read-line ip 'return-linefeed))
+    (define-values (new-url chunked? headers)
+      (let loop ([new-url #f] [chunked? #f] [headers '()])
+        (define line (read-line ip 'return-linefeed))
+        (when (eof-object? line)
+          (error 'getpost-pure-port 
+                 "connection ended before headers ended (when trying to follow a redirection)"))
+        (cond
+          [(equal? line "") (values new-url chunked? headers)]
+          [(equal? chunked-header-line line) (loop new-url #t (cons line headers))]
+          [(regexp-match #rx"^Location: (.*)$" line)
+           =>
+           (λ (m) 
+             (define m1 (list-ref m 1))
+             (define url (with-handlers ((exn:fail? (λ (x) #f)))
+                           (string->url m1)))
+             (loop (or url new-url) chunked? (cons line headers)))]
+          [else (loop new-url chunked? (cons line headers))])))
+    (define redirection-status-line?
+      (regexp-match #rx"^HTTP/[0-9]+[.][0-9]+ 3[0-9][0-9]" status))
+    (cond
+      [(and redirection-status-line? new-url (not (zero? redirections))) 
+       (redirection-loop (- redirections 1) new-url)]
+      [else
+       (define-values (in-pipe out-pipe) (make-pipe))
+       (thread
+        (λ ()
+          (http-pipe-data chunked? ip out-pipe)
+          (close-input-port ip)))
+       (values in-pipe
+               (apply string-append (map (λ (x) (string-append x "\r\n"))
+                                         (reverse headers))))])))
+
 ;; get-pure-port : url [x list (str)] -> in-port
 (define (get-pure-port url [strings '()] #:redirections [redirections 0])
   (getpost-pure-port #t url #f strings redirections))
@@ -342,11 +380,13 @@
     (error 'purify-http-port "Connection ended before headers ended"))
   (if (string=? l "")
       #f
-      (if (string=? l "Transfer-Encoding: chunked")
+      (if (string=? l chunked-header-line)
           (begin (http-read-headers ip)
                  #t)
           (http-read-headers ip))))
 
+(define chunked-header-line "Transfer-Encoding: chunked")
+
 (define (http-pipe-data chunked? ip op)
   (if chunked?
       (http-pipe-chunk ip op)
@@ -626,7 +666,7 @@
  (url->string (url? . -> . string?))
  (url->path (->* (url?) ((one-of/c 'unix 'windows)) path-for-some-system?))
 
- (get-pure-port (->* (url?) ((listof string?)) input-port?))
+ (get-pure-port (->* (url?) ((listof string?) #:redirections exact-nonnegative-integer?) input-port?))
  (get-impure-port (->* (url?) ((listof string?)) input-port?))
  (post-pure-port (->* (url? (or/c false/c bytes?)) ((listof string?)) input-port?))
  (post-impure-port (->* (url? bytes?) ((listof string?)) input-port?))
@@ -638,6 +678,8 @@
  (put-impure-port (->* (url? bytes?) ((listof string?)) input-port?))
  (display-pure-port (input-port? . -> . void?))
  (purify-port (input-port? . -> . string?))
+ (get-pure-port/headers (->* (url?) ((listof string?) #:redirections exact-nonnegative-integer?) 
+                             (values input-port? string?)))
  (netscape/string->url (string? . -> . url?))
  (call/input-url (case-> (-> url?
                              (-> 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)
 

doc/release-notes/racket/HISTORY.txt

@@ -3,6 +3,7 @@ Added exn:fail:syntax:unbound
 Added date*, which extends date to include nanoseconds and a 
  time zone name
 Changed seconds->date to accept a real number return a date*
+Added support for redirections to get-pure-port
 
 Version 5.1.3.10
 Added variable-reference->module-declare-inspector, which allows