Adding tests, some broken
svn: r6547
This commit is contained in:
Jay McCarthy
parent
860ee82a67
commit
7ffe04365c
|
|
@ -18,11 +18,11 @@
|
|||
(define (response? x)
|
||||
(or (response/basic? x)
|
||||
; this could fail for dotted lists - rewrite andmap
|
||||
(and (pair? x) (pair? (cdr x)) (andmap
|
||||
(lambda (x)
|
||||
(or (string? x)
|
||||
(bytes? x)))
|
||||
x))
|
||||
(and (pair? x) (andmap
|
||||
(lambda (x)
|
||||
(or (string? x)
|
||||
(bytes? x)))
|
||||
x))
|
||||
; insist that the xexpr has a root element
|
||||
(and (pair? x) (xexpr? x))))
|
||||
|
||||
|
|
|
|||
|
|
@ -2,14 +2,16 @@
|
|||
(require (lib "contract.ss")
|
||||
(lib "port.ss")
|
||||
(lib "pretty.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "xml.ss" "xml")
|
||||
"connection-manager.ss"
|
||||
"../private/response-structs.ss"
|
||||
"util.ss")
|
||||
; XXX Fix this insanity
|
||||
|
||||
;; Weak contracts for output-response because the response? is checked inside
|
||||
;; output-response, handled, etc.
|
||||
; XXX Make return contracts correct
|
||||
(provide/contract
|
||||
; XXX Make contract stronger
|
||||
[rename ext:output-response output-response (connection? any/c . -> . any)]
|
||||
[rename ext:output-response/method output-response/method (connection? response? symbol? . -> . any)]
|
||||
[rename ext:output-file output-file (connection? path? symbol? bytes? integer? integer? . -> . any)])
|
||||
|
|
@ -127,7 +129,7 @@
|
|||
(cond
|
||||
[(response/full? resp)
|
||||
(output-response/basic
|
||||
conn resp (response/full->size resp)
|
||||
conn resp (response->size resp)
|
||||
(lambda (o-port)
|
||||
(for-each
|
||||
(lambda (str) (display str o-port))
|
||||
|
|
@ -138,15 +140,13 @@
|
|||
(output-response/basic
|
||||
conn
|
||||
(make-response/basic 200 "Okay" (current-seconds) (car resp) '())
|
||||
(apply + (map
|
||||
data-length
|
||||
(cdr resp)))
|
||||
(response->size resp)
|
||||
(lambda (o-port)
|
||||
(for-each
|
||||
(lambda (str) (display str o-port))
|
||||
(cdr resp))))]
|
||||
[else
|
||||
;; TODO: make a real exception for this.
|
||||
; XXX: make a real exception for this.
|
||||
(with-handlers
|
||||
([exn:invalid-xexpr?
|
||||
(lambda (exn)
|
||||
|
|
@ -156,6 +156,7 @@
|
|||
'ignored))]
|
||||
[exn? (lambda (exn)
|
||||
(raise exn))])
|
||||
; XXX Don't validate here
|
||||
(let ([str (and (validate-xexpr resp) (xexpr->string resp))])
|
||||
(output-response/basic
|
||||
conn
|
||||
|
|
@ -172,12 +173,30 @@
|
|||
(define ext:output-response
|
||||
(ext:wrap output-response))
|
||||
|
||||
;; response/full->size: response/full -> number
|
||||
;; compute the size for a response/full
|
||||
(define (response/full->size resp/f)
|
||||
(apply + (map
|
||||
data-length
|
||||
(response/full-body resp/f))))
|
||||
;; response->size: response -> number
|
||||
;; compute the size for a response
|
||||
(define (response->size resp)
|
||||
(match resp
|
||||
[(? response/full?)
|
||||
(apply + (map
|
||||
data-length
|
||||
(response/full-body resp)))]
|
||||
[(? response/incremental?)
|
||||
(define total (box 0))
|
||||
((response/incremental-generator resp)
|
||||
(lambda chunks
|
||||
(set-box! total (apply + (unbox total) (map data-length chunks)))))
|
||||
(unbox total)]
|
||||
[_
|
||||
(if (and (pair? resp) (bytes? (car resp)))
|
||||
(apply + (map
|
||||
data-length
|
||||
(cdr resp)))
|
||||
(add1
|
||||
(data-length
|
||||
; XXX Don't validate here
|
||||
(and (validate-xexpr resp)
|
||||
(xexpr->string resp)))))]))
|
||||
|
||||
;; **************************************************
|
||||
;; output-file: connection path symbol bytes integer integer -> void
|
||||
|
|
@ -205,7 +224,7 @@
|
|||
|
||||
(define ext:output-file
|
||||
(ext:wrap output-file))
|
||||
|
||||
|
||||
; XXX Check method in response
|
||||
;; **************************************************
|
||||
;; output-response/method: connection response/full symbol -> void
|
||||
|
|
@ -213,8 +232,9 @@
|
|||
(define (output-response/method conn resp meth)
|
||||
(cond
|
||||
[(eqv? meth 'head)
|
||||
(output-headers/response conn resp `(("Content-Length: "
|
||||
,(response/full->size resp))))]
|
||||
(output-headers/response conn resp
|
||||
`(("Content-Length: "
|
||||
,(response->size resp))))]
|
||||
[else
|
||||
(output-response conn resp)]))
|
||||
|
||||
|
|
@ -228,7 +248,7 @@
|
|||
(output-headers conn
|
||||
(response/basic-code resp)
|
||||
(response/basic-message resp)
|
||||
extras
|
||||
(append extras (extras->strings resp))
|
||||
(response/basic-seconds resp)
|
||||
(response/basic-mime resp)))
|
||||
|
||||
|
|
@ -237,14 +257,12 @@
|
|||
;; Write a normal response to an output port
|
||||
(define (output-response/basic conn resp size responder)
|
||||
(output-headers/response conn resp
|
||||
`(("Content-Length: " ,size)
|
||||
. ,(extras->strings resp)))
|
||||
`(("Content-Length: " ,size)))
|
||||
(responder (connection-o-port conn)))
|
||||
|
||||
;; **************************************************
|
||||
;; output-response/incremental: connection response/incremental -> void
|
||||
;; Write a chunked response to an output port.
|
||||
; XXX How does this end?
|
||||
(define (output-response/incremental conn resp/inc)
|
||||
(let ([o-port (connection-o-port conn)])
|
||||
(cond
|
||||
|
|
@ -255,8 +273,7 @@
|
|||
(for-each (lambda (chunk) (display chunk o-port)) chunks)))]
|
||||
[else
|
||||
(output-headers/response conn resp/inc
|
||||
`(("Transfer-Encoding: chunked")
|
||||
. ,(extras->strings resp/inc)))
|
||||
`(("Transfer-Encoding: chunked")))
|
||||
((response/incremental-generator resp/inc)
|
||||
(lambda chunks
|
||||
(fprintf o-port "~x\r\n"
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
(module response-test mzscheme
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "file.ss")
|
||||
(lib "response.ss" "web-server" "private")
|
||||
(lib "response-structs.ss" "web-server" "private")
|
||||
(lib "connection-manager.ss" "web-server" "private")
|
||||
|
|
@ -25,7 +27,6 @@
|
|||
#"Last-Modified: XXX GMT\r\n")
|
||||
#"Date: XXX GMT\r\n"))
|
||||
|
||||
; XXX
|
||||
(define response-tests
|
||||
(test-suite
|
||||
"HTTP Responses"
|
||||
|
|
@ -118,9 +119,150 @@
|
|||
(output output-response
|
||||
`(html (head (title "Hey!")) (body "Content")))
|
||||
#"HTTP/1.1 200 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nContent-Length: 66\r\n\r\n<html><head><title>Hey!</title></head><body>Content</body></html>\n")))
|
||||
; XXX
|
||||
(test-suite
|
||||
"output-response/method")
|
||||
"output-response/method"
|
||||
(test-suite
|
||||
"response/full"
|
||||
(test-equal? "response/full"
|
||||
(output output-response/method
|
||||
(make-response/full 404 "404" (current-seconds) #"text/html"
|
||||
(list) (list))
|
||||
'head)
|
||||
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n")
|
||||
(test-equal? "response/full (header)"
|
||||
(output output-response/method
|
||||
(make-response/full 404 "404" (current-seconds) #"text/html"
|
||||
(list (cons 'Header "Value")) (list))
|
||||
'head)
|
||||
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\nHeader: Value\r\n\r\n")
|
||||
(test-equal? "response/full (body)"
|
||||
(output output-response/method
|
||||
(make-response/full 404 "404" (current-seconds) #"text/html"
|
||||
(list) (list "Content!"))
|
||||
'head)
|
||||
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 8\r\n\r\n")
|
||||
(test-equal? "response/full (bytes body)"
|
||||
(output output-response/method
|
||||
(make-response/full 404 "404" (current-seconds) #"text/html"
|
||||
(list) (list #"Content!"))
|
||||
'head)
|
||||
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 8\r\n\r\n")
|
||||
(test-equal? "response/full (both)"
|
||||
(output output-response/method
|
||||
(make-response/full 404 "404" (current-seconds) #"text/html"
|
||||
(list (cons 'Header "Value")) (list "Content!"))
|
||||
'head)
|
||||
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 8\r\nHeader: Value\r\n\r\n"))
|
||||
(test-suite
|
||||
"response/incremental"
|
||||
(test-equal? "response/incremental"
|
||||
(output output-response/method
|
||||
(make-response/incremental 404 "404" (current-seconds) #"text/html"
|
||||
(list) (lambda (write) (void)))
|
||||
'head)
|
||||
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n")
|
||||
(test-equal? "response/incremental (header)"
|
||||
(output output-response/method
|
||||
(make-response/incremental 404 "404" (current-seconds) #"text/html"
|
||||
(list (cons 'Header "Value"))
|
||||
(lambda (write) (void)))
|
||||
'head)
|
||||
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\nHeader: Value\r\n\r\n")
|
||||
(test-equal? "response/incremental (body)"
|
||||
(output output-response/method
|
||||
(make-response/incremental 404 "404" (current-seconds) #"text/html"
|
||||
(list)
|
||||
(lambda (write) (write "Content!")))
|
||||
'head)
|
||||
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 8\r\n\r\n")
|
||||
(test-equal? "response/incremental (bytes body)"
|
||||
(output output-response/method
|
||||
(make-response/incremental 404 "404" (current-seconds) #"text/html"
|
||||
(list)
|
||||
(lambda (write) (write #"Content!")))
|
||||
'head)
|
||||
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 8\r\n\r\n")
|
||||
(test-equal? "response/incremental (both)"
|
||||
(output output-response/method
|
||||
(make-response/incremental 404 "404" (current-seconds) #"text/html"
|
||||
(list (cons 'Header "Value"))
|
||||
(lambda (write) (write "Content!")))
|
||||
'head)
|
||||
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 8\r\nHeader: Value\r\n\r\n")
|
||||
(test-equal? "response/incremental (twice)"
|
||||
(output output-response/method
|
||||
(make-response/incremental 404 "404" (current-seconds) #"text/html"
|
||||
(list (cons 'Header "Value"))
|
||||
(lambda (write)
|
||||
(write "Content!")
|
||||
(write "Content!")))
|
||||
'head)
|
||||
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 16\r\nHeader: Value\r\n\r\n"))
|
||||
(test-suite
|
||||
"Simple content"
|
||||
(test-equal? "empty"
|
||||
(output output-response/method
|
||||
(list #"text/html")
|
||||
'head)
|
||||
#"HTTP/1.1 200 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n")
|
||||
(test-equal? "not"
|
||||
(output output-response/method
|
||||
(list #"text/html" "Content")
|
||||
'head)
|
||||
#"HTTP/1.1 200 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 7\r\n\r\n")
|
||||
(test-equal? "not, bytes"
|
||||
(output output-response/method
|
||||
(list #"text/html" #"Content")
|
||||
'head)
|
||||
#"HTTP/1.1 200 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 7\r\n\r\n"))
|
||||
(test-suite
|
||||
"xexpr"
|
||||
(test-equal? "any"
|
||||
(output output-response/method
|
||||
`(html (head (title "Hey!")) (body "Content"))
|
||||
'head)
|
||||
#"HTTP/1.1 200 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nContent-Length: 66\r\n\r\n")))
|
||||
; XXX
|
||||
(test-suite
|
||||
"output-file"))))
|
||||
(let ()
|
||||
(define tmp-file (make-temporary-file))
|
||||
(with-output-to-file tmp-file
|
||||
(lambda ()
|
||||
(display
|
||||
(xexpr->string
|
||||
`(html (head (title "A title"))
|
||||
(body "Here's some content!")))))
|
||||
'truncate/replace)
|
||||
(test-suite
|
||||
"output-file"
|
||||
(test-equal? "(get) whole-file"
|
||||
(output output-file tmp-file 'get #"text/html"
|
||||
0 +inf.0)
|
||||
#"HTTP/1.1 206 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 81\r\nContent-Range: bytes 0-81/81\r\n\r\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
(test-equal? "(get) end early"
|
||||
(output output-file tmp-file 'get #"text/html"
|
||||
0 10)
|
||||
#"HTTP/1.1 206 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 10\r\nContent-Range: bytes 0-10/81\r\n\r\n<html><hea")
|
||||
(test-equal? "(get) start late"
|
||||
(output output-file tmp-file 'get #"text/html"
|
||||
10 +inf.0)
|
||||
#"HTTP/1.1 206 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 71\r\nContent-Range: bytes 10-81/81\r\n\r\nd><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
(test-equal? "(get) start late and end early"
|
||||
(output output-file tmp-file 'get #"text/html"
|
||||
5 10)
|
||||
#"HTTP/1.1 206 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 5\r\nContent-Range: bytes 5-10/81\r\n\r\n><head><ti")
|
||||
(test-equal? "(head) whole-file"
|
||||
(output output-file tmp-file 'head #"text/html"
|
||||
0 +inf.0)
|
||||
#"HTTP/1.1 206 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 81\r\nContent-Range: bytes 0-81/81\r\n\r\n")
|
||||
(test-equal? "(head) end early"
|
||||
(output output-file tmp-file 'head #"text/html"
|
||||
0 10)
|
||||
#"HTTP/1.1 206 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 10\r\nContent-Range: bytes 0-10/81\r\n\r\n")
|
||||
(test-equal? "(head) start late"
|
||||
(output output-file tmp-file 'head #"text/html"
|
||||
10 +inf.0)
|
||||
#"HTTP/1.1 206 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 71\r\nContent-Range: bytes 10-81/81\r\n\r\n")
|
||||
(test-equal? "(head) start late and end early"
|
||||
(output output-file tmp-file 'head #"text/html"
|
||||
1 10)
|
||||
#"HTTP/1.1 206 Okay\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 9\r\nContent-Range: bytes 1-10/81\r\n\r\n"))))))
|
||||
Loading…
Reference in New Issue
Block a user