Fixing PR 10970

collects/meta/props

@@ -1449,6 +1449,7 @@ path/s is either such a string or a list of them.
 "collects/tests/mysterx/mystests.rktl" drdr:command-line #f
 "collects/tests/mzcom" responsible (mflatt)
 "collects/tests/mzcom/test.rktl" drdr:command-line #f
+"collects/tests/net/url-port.rkt" responsible (jay)
 "collects/tests/plai" responsible (jay)
 "collects/tests/plai/gc/bad-mutators/mut-1.rkt" drdr:command-line #f
 "collects/tests/plai/gc/bad-mutators/mutator0.rkt" drdr:command-line #f

collects/net/url-unit.rkt

@@ -197,11 +197,7 @@
                (string=? scheme "https"))
            (let ([port (http://getpost-impure-port
                         get? url post-data strings)])
-             (with-handlers ([void (lambda (exn)
-                                     (close-input-port port)
-                                     (raise exn))])
-               (purify-port port))
-             port)]
+             (purify-http-port port))]
           [(string=? scheme "file")
            (file://get-pure-port url)]
           [else (url-error "Scheme ~a unsupported" scheme)])))
@@ -322,6 +318,51 @@
             #rx"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)" port)])
     (if m (read-string (cdar m) port) "")))
 
+;; purify-http-port : in-port -> in-port
+(define (purify-http-port in-port)
+  (define-values (in-pipe out-pipe) (make-pipe))
+  (thread
+   (λ ()
+     (define status (http-read-status in-port))
+     (define chunked? (http-read-headers in-port))
+     (http-pipe-data chunked? in-port out-pipe)))
+  in-pipe)
+
+(define (http-read-status ip)
+  (read-line ip 'return-linefeed))
+
+(define (http-read-headers ip)
+  (define l (read-line ip 'return-linefeed))
+  (when (eof-object? l)
+    (error 'purify-http-port "Connection ended before headers ended"))
+  (if (string=? l "")
+      #f
+      (if (string=? l "Transfer-Encoding: chunked")
+          (begin (http-read-headers ip)
+                 #t)
+          (http-read-headers ip))))
+
+(define (http-pipe-data chunked? ip op)
+  (if chunked?
+      (http-pipe-chunk ip op)
+      (begin
+        (copy-port ip op)
+        (flush-output op)
+        (close-output-port op))))
+
+(define (http-pipe-chunk ip op)
+  (define size-str (read-line ip 'return-linefeed))
+  (define chunk-size (string->number size-str 16))
+  (unless chunk-size
+    (error 'http-pipe-chunk "Could not parse ~S as hexadecimal number" size-str))
+  (if (zero? chunk-size)
+      (begin (flush-output op)
+             (close-output-port op))
+      (let* ([bs (read-bytes chunk-size ip)]
+             [crlf (read-bytes 2 ip)])
+        (write-bytes bs op)
+        (http-pipe-chunk ip op))))
+
 (define character-set-size 256)
 
 ;; netscape/string->url : str -> url
@@ -528,11 +569,7 @@
           [(or (string=? scheme "http") (string=? scheme "https"))
            (let ([port (http://method-impure-port
                         method url data strings)])
-             (with-handlers ([void (lambda (exn)
-                                     (close-input-port port)
-                                     (raise exn))])
-               (purify-port port))
-             port)]
+             (purify-http-port port))]
           [(string=? scheme "file")
            (file://get-pure-port url)]
           [else (url-error "Scheme ~a unsupported" scheme)])))

collects/tests/net/url-port.rkt

@@ -0,0 +1,55 @@
+#lang racket
+(require net/url
+         mzlib/thread
+         tests/eli-tester)
+
+(define ((make-tester url->port) response)
+  (define port-no (+ 9000 (random 100)))
+  (define server-cust
+    (make-custodian))
+  (parameterize ([current-custodian server-cust])
+    (thread 
+     (λ ()
+       (run-server port-no 
+                   (lambda (ip op)
+                     (thread (λ () (port->string ip)))
+                     (display response op)
+                     (flush-output op))
+                   +inf.0))))
+  (sleep 1)
+  (dynamic-wind
+   void
+   (λ ()
+     (port->string
+      (url->port
+       (url "http" #f "localhost" port-no
+            #t empty empty #f))))
+   (λ ()
+     (custodian-shutdown-all server-cust))))  
+
+(define get-pure
+  (make-tester get-pure-port))
+(define get-impure
+  (make-tester get-impure-port))
+
+(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")
+ =>
+ "This is the data in the first chunk and this is the second one"
+ 
+ (get-pure
+  "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-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")
+ =>
+ "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-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"
+ )