Outputing with chunked encoding

collects/tests/web-server/dispatchers/dispatch-files-test.rkt

@@ -115,7 +115,7 @@
                 #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n")
    (test-equal?* "dir, not dir-url, get"
                 (collect (dispatch #t a-dir) (req #f #"GET" empty))
-                #"HTTP/1.1 302 Moved Temporarily\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nConnection: close\r\nLocation: /foo/\r\n\r\n")
+                #"HTTP/1.1 302 Moved Temporarily\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nLocation: /foo/\r\n\r\n")
    (test-exn "dir, not exists, get"
              exn:dispatcher?
              (lambda () (collect (dispatch #f a-dir) (req #t #"GET" empty))))

collects/tests/web-server/private/request-test.rkt

@@ -92,6 +92,31 @@
 
     (test-suite
      "Chunked transfer-encoding"
+     (test-equal? "example"
+                  (test-read-request
+                   #"POST http://127.0.0.1/test HTTP/1.0
+Date: Fri, 31 Dec 1999 23:59:59 GMT
+Content-Type: text/plain
+Content-Length: 42
+
+abcdefghijklmnopqrstuvwxyz1234567890abcdef
+")
+                  (list
+                   (list
+                    'request
+                    (list
+                     #"POST"
+                     "http://127.0.0.1/test"
+                     (list
+                      (header #"Date" #"Fri, 31 Dec 1999 23:59:59 GMT")
+                      (header #"Content-Type" #"text/plain")
+                      (header #"Content-Length" #"42"))
+                     '()
+                     #"abcdefghijklmnopqrstuvwxyz1234567890abcdef"
+                     "to"
+                     80
+                     "from"))
+                   #t))
      (test-equal? "example"
                   (test-read-request
                    #"POST http://127.0.0.1/test HTTP/1.1

collects/tests/web-server/private/response-test.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require rackunit
+(require racket/slice
+         rackunit
          racket/port
          xml/xml
          (only-in mzlib/file
@@ -35,38 +36,38 @@
                   (output output-response 
                           (response 404 #"404" (current-seconds) #"text/html"
                                     (list) void))
-                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nConnection: close\r\n\r\n")
+                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\n\r\n")
      (test-equi? "response" 
                   (output output-response 
                           (response 404 #"404" (current-seconds) #f
                                     (list) void))
-                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nConnection: close\r\n\r\n")
+                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\n\r\n")
      (test-equi? "response (header)" 
                   (output output-response 
                           (response 404 #"404" (current-seconds) #"text/html"
                                     (list (make-header #"Header" #"Value")) void))
-                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nConnection: close\r\nHeader: Value\r\n\r\n")
+                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nHeader: Value\r\n\r\n")
      (test-equi? "response (body)" 
                   (output output-response 
                           (response 404 #"404" (current-seconds) #"text/html"
                                     (list) void))
-                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nConnection: close\r\n\r\n")
+                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\n\r\n")
      (test-equi? "response (bytes body)"
                   (output output-response 
                           (response 404 #"404" (current-seconds) #"text/html"
                                     (list) void))
-                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nConnection: close\r\n\r\n")
+                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\n\r\n")
      (test-equi? "response (both)" 
                   (output output-response 
                           (response 404 #"404" (current-seconds) #"text/html"
                                     (list (make-header #"Header" #"Value")) void))
-                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nConnection: close\r\nHeader: Value\r\n\r\n")
+                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nHeader: Value\r\n\r\n")
      (test-equi? "response (both)" 
                   (output output-response 
                           (response 404 #"404" (current-seconds) #"text/html"
                                     (list (make-header #"Header" #"Value1")
                                           (make-header #"Header" #"Value2")) void))
-                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nConnection: close\r\nHeader: Value1\r\nHeader: Value2\r\n\r\n"))
+                  #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nHeader: Value1\r\nHeader: Value2\r\n\r\n"))
     
     (test-suite 
      "response/full"
@@ -112,7 +113,7 @@
      (test-equi? "any"
                   (output output-response
                           (response/xexpr `(html (head (title "Hey!")) (body "Content"))))
-                  #"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\nConnection: close\r\n\r\n<html><head><title>Hey!</title></head><body>Content</body></html>"))
+                  #"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\n\r\n<html><head><title>Hey!</title></head><body>Content</body></html>"))
     ))
 
 (define output-response/method-tests
@@ -176,7 +177,7 @@
                   (output output-response/method
                           (response/xexpr `(html (head (title "Hey!")) (body "Content")))
                           #"HEAD")
-                  #"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\nConnection: close\r\n\r\n"))))
+                  #"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\n\r\n"))))
 
 (define response-tests
   (test-suite
@@ -305,3 +306,7 @@
                    (output output-file/boundary tmp-file #"HEAD" #"text/html" '((-10 . -5) (1000 . 1050) (50 . 49)) #"BOUNDARY"))
                      (get-output-string os))
                   "")))))
+
+(slice test
+  (require rackunit/text-ui)
+  (run-tests response-tests))

collects/tests/web-server/util.rkt

@@ -53,18 +53,21 @@
   (define ip (open-input-bytes ib))
   (define op (open-output-bytes))
   (values (make-connection 0 (make-timer never-evt +inf.0 (lambda () (void)))
-                           ip op (make-custodian) #f)
+                           ip op (make-custodian) #t)
           ip
           op))
 
 (define (redact b)
-  (regexp-replace 
+  (regexp-replace
-   #"Date: [a-zA-Z0-9:, ]+ GMT\r\n"
+   #"Connection: close\r\n"
-   (regexp-replace
+   (regexp-replace 
-    #"Last-Modified: [a-zA-Z0-9:, ]+ GMT\r\n"
+    #"Date: [a-zA-Z0-9:, ]+ GMT\r\n"
-    b
+    (regexp-replace
-    #"Last-Modified: REDACTED GMT\r\n")
+     #"Last-Modified: [a-zA-Z0-9:, ]+ GMT\r\n"
-   #"Date: REDACTED GMT\r\n"))
+     b
+     #"Last-Modified: REDACTED GMT\r\n")
+    #"Date: REDACTED GMT\r\n")
+   #""))
 
 (define-syntax (make-module-eval m-expr)
   (syntax-case m-expr (module)

collects/web-server/http/response.rkt

@@ -22,12 +22,22 @@
   (output-response/method conn resp #"GET"))
 
 (define (output-response/method conn resp meth)
-  ; XXX Use chunked encoding for non-terminated responses
+  (cond
-  (unless (terminated-response? resp)
+    [(or 
-    (set-connection-close?! conn #t))
+      ;; If it is terminated, just continue
-  (output-response-head conn resp)
+      (terminated-response? resp)
-  (unless (bytes-ci=? meth #"HEAD")
+      ;; If it is HTTP/1.0, ditto
-    (output-response-body conn resp)))
+      (connection-close? conn)
+      ;; Or, if it is a HEAD request
+      (bytes-ci=? meth #"HEAD"))
+     (output-response-head conn resp)
+     (unless (bytes-ci=? meth #"HEAD")
+       (output-response-body conn resp))]
+    ;; Otherwise, use chunked encoding
+    [else
+     (output-response-head conn resp
+                           (list (header #"Transfer-Encoding" #"chunked")))
+     (output-response-body/chunked conn resp)]))
 
 ;; Write the headers portion of a response to an output port.
 ;; NOTE: According to RFC 2145 the server should write HTTP/1.1
@@ -40,12 +50,12 @@
   (append (maybe-header h k v)
           ...))
 
-(define (output-response-head conn bresp)
+(define (output-response-head conn bresp [more-hs empty])
   (fprintf (connection-o-port conn)
            "HTTP/1.1 ~a ~a\r\n"
            (response-code bresp)
            (response-message bresp))
-  (define hs (response-headers bresp))
+  (define hs (append (response-headers bresp) more-hs))
   (define seen? (make-hash))
   (for ([h (in-list hs)])
     (hash-set! seen? (header-field h) #t))
@@ -99,6 +109,33 @@
   ((response-output bresp) o-port)
   (flush-output o-port))
 
+(define (output-response-body/chunked conn bresp)
+  (define-values (from-servlet to-chunker) (make-pipe))
+  (define to-client (connection-o-port conn))
+  (define to-chunker-t    
+    (thread (λ () 
+              ((response-output bresp) to-chunker)
+              (close-output-port to-chunker))))
+  (define buffer (make-bytes 1024))
+  (define total-size
+    (let loop ([total-size 0])
+      (define bytes-read-or-eof
+        (read-bytes-avail! buffer from-servlet))
+      (if (eof-object? bytes-read-or-eof)
+        total-size
+        (begin 
+          (fprintf to-client "~a\r\n" (number->string bytes-read-or-eof 16))
+          (write-bytes buffer to-client 0 bytes-read-or-eof)
+          (fprintf to-client "\r\n")
+          (loop (+ total-size bytes-read-or-eof))))))
+  (thread-wait to-chunker-t)
+  (fprintf to-client "0\r\n")
+  (print-headers 
+   to-client
+   (list (header #"Content-Length" 
+                 (string->bytes/utf-8 (number->string total-size)))))
+  (flush-output to-client))
+
 ; seconds->gmt-string : Nat -> String
 ; format is rfc1123 compliant according to rfc2068 (http/1.1)
 (define (seconds->gmt-string s)

collects/web-server/test.rkt

@@ -72,7 +72,7 @@
   (define ip (open-input-bytes ib))
   (define op (open-output-bytes))
   (values (make-connection 0 (make-timer never-evt +inf.0 (lambda () (void)))
-                           ip op (current-custodian) #f)
+                           ip op (current-custodian) #t)
           ip
           op))