suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Outputing with chunked encoding

Browse Source
This commit is contained in:
Jay McCarthy 2012-03-12 16:14:07 -06:00
parent 1e80084c97
commit b1aae4a12d
6 changed files with 98 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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))))

25
collects/tests/web-server/private/request-test.rkt
View File

@ -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

25
collects/tests/web-server/private/response-test.rkt
View File

@ -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))

7
collects/tests/web-server/util.rkt
View File

@ -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
#"Connection: close\r\n"
(regexp-replace
#"Date: [a-zA-Z0-9:, ]+ GMT\r\n"
(regexp-replace
#"Last-Modified: [a-zA-Z0-9:, ]+ GMT\r\n"
b
#"Last-Modified: REDACTED GMT\r\n")
#"Date: REDACTED GMT\r\n"))
#"Date: REDACTED GMT\r\n")
#""))
(define-syntax (make-module-eval m-expr)
(syntax-case m-expr (module)

49
collects/web-server/http/response.rkt
View File

@ -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
(unless (terminated-response? resp)
(set-connection-close?! conn #t))
(cond
[(or
;; If it is terminated, just continue
(terminated-response? resp)
;; If it is HTTP/1.0, ditto
(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)))
(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)

2
collects/web-server/test.rkt
View File

@ -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))