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

Adding tests, some broken

Browse Source 
svn: r6547
This commit is contained in:
Jay McCarthy 2007-06-08 17:57:38 +00:00
parent 860ee82a67
commit 7ffe04365c
3 changed files with 191 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/web-server/private/response-structs.ss
View File

@ -18,11 +18,11 @@
(define (response? x) (define (response? x)
(or (response/basic? x) (or (response/basic? x)
; this could fail for dotted lists - rewrite andmap ; this could fail for dotted lists - rewrite andmap
(and (pair? x) (pair? (cdr x)) (andmap (and (pair? x) (andmap
(lambda (x) (lambda (x)
(or (string? x) (or (string? x)
(bytes? x))) (bytes? x)))
x)) x))
; insist that the xexpr has a root element ; insist that the xexpr has a root element
(and (pair? x) (xexpr? x)))) (and (pair? x) (xexpr? x))))

61
collects/web-server/private/response.ss
View File

@ -2,14 +2,16 @@
(require (lib "contract.ss") (require (lib "contract.ss")
(lib "port.ss") (lib "port.ss")
(lib "pretty.ss") (lib "pretty.ss")
(lib "plt-match.ss")
(lib "xml.ss" "xml") (lib "xml.ss" "xml")
"connection-manager.ss" "connection-manager.ss"
"../private/response-structs.ss" "../private/response-structs.ss"
"util.ss") "util.ss")
; XXX Fix this insanity
;; Weak contracts for output-response because the response? is checked inside ; XXX Make return contracts correct
;; output-response, handled, etc.
(provide/contract (provide/contract
; XXX Make contract stronger
[rename ext:output-response output-response (connection? any/c . -> . any)] [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-response/method output-response/method (connection? response? symbol? . -> . any)]
[rename ext:output-file output-file (connection? path? symbol? bytes? integer? integer? . -> . any)]) [rename ext:output-file output-file (connection? path? symbol? bytes? integer? integer? . -> . any)])
@ -127,7 +129,7 @@
(cond (cond
[(response/full? resp) [(response/full? resp)
(output-response/basic (output-response/basic
conn resp (response/full->size resp) conn resp (response->size resp)
(lambda (o-port) (lambda (o-port)
(for-each (for-each
(lambda (str) (display str o-port)) (lambda (str) (display str o-port))
@ -138,15 +140,13 @@
(output-response/basic (output-response/basic
conn conn
(make-response/basic 200 "Okay" (current-seconds) (car resp) '()) (make-response/basic 200 "Okay" (current-seconds) (car resp) '())
(apply + (map (response->size resp)
data-length
(cdr resp)))
(lambda (o-port) (lambda (o-port)
(for-each (for-each
(lambda (str) (display str o-port)) (lambda (str) (display str o-port))
(cdr resp))))] (cdr resp))))]
[else [else
;; TODO: make a real exception for this. ; XXX: make a real exception for this.
(with-handlers (with-handlers
([exn:invalid-xexpr? ([exn:invalid-xexpr?
(lambda (exn) (lambda (exn)
@ -156,6 +156,7 @@
'ignored))] 'ignored))]
[exn? (lambda (exn) [exn? (lambda (exn)
(raise exn))]) (raise exn))])
; XXX Don't validate here
(let ([str (and (validate-xexpr resp) (xexpr->string resp))]) (let ([str (and (validate-xexpr resp) (xexpr->string resp))])
(output-response/basic (output-response/basic
conn conn
@ -172,12 +173,30 @@
(define ext:output-response (define ext:output-response
(ext:wrap output-response)) (ext:wrap output-response))
;; response/full->size: response/full -> number ;; response->size: response -> number
;; compute the size for a response/full ;; compute the size for a response
(define (response/full->size resp/f) (define (response->size resp)
(apply + (map (match resp
data-length [(? response/full?)
(response/full-body resp/f)))) (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 ;; output-file: connection path symbol bytes integer integer -> void
@ -205,7 +224,7 @@
(define ext:output-file (define ext:output-file
(ext:wrap output-file)) (ext:wrap output-file))
; XXX Check method in response ; XXX Check method in response
;; ************************************************** ;; **************************************************
;; output-response/method: connection response/full symbol -> void ;; output-response/method: connection response/full symbol -> void
@ -213,8 +232,9 @@
(define (output-response/method conn resp meth) (define (output-response/method conn resp meth)
(cond (cond
[(eqv? meth 'head) [(eqv? meth 'head)
(output-headers/response conn resp `(("Content-Length: " (output-headers/response conn resp
,(response/full->size resp))))] `(("Content-Length: "
,(response->size resp))))]
[else [else
(output-response conn resp)])) (output-response conn resp)]))
@ -228,7 +248,7 @@
(output-headers conn (output-headers conn
(response/basic-code resp) (response/basic-code resp)
(response/basic-message resp) (response/basic-message resp)
extras (append extras (extras->strings resp))
(response/basic-seconds resp) (response/basic-seconds resp)
(response/basic-mime resp))) (response/basic-mime resp)))
@ -237,14 +257,12 @@
;; Write a normal response to an output port ;; Write a normal response to an output port
(define (output-response/basic conn resp size responder) (define (output-response/basic conn resp size responder)
(output-headers/response conn resp (output-headers/response conn resp
`(("Content-Length: " ,size) `(("Content-Length: " ,size)))
. ,(extras->strings resp)))
(responder (connection-o-port conn))) (responder (connection-o-port conn)))
;; ************************************************** ;; **************************************************
;; output-response/incremental: connection response/incremental -> void ;; output-response/incremental: connection response/incremental -> void
;; Write a chunked response to an output port. ;; Write a chunked response to an output port.
; XXX How does this end?
(define (output-response/incremental conn resp/inc) (define (output-response/incremental conn resp/inc)
(let ([o-port (connection-o-port conn)]) (let ([o-port (connection-o-port conn)])
(cond (cond
@ -255,8 +273,7 @@
(for-each (lambda (chunk) (display chunk o-port)) chunks)))] (for-each (lambda (chunk) (display chunk o-port)) chunks)))]
[else [else
(output-headers/response conn resp/inc (output-headers/response conn resp/inc
`(("Transfer-Encoding: chunked") `(("Transfer-Encoding: chunked")))
. ,(extras->strings resp/inc)))
((response/incremental-generator resp/inc) ((response/incremental-generator resp/inc)
(lambda chunks (lambda chunks
(fprintf o-port "~x\r\n" (fprintf o-port "~x\r\n"

152
collects/web-server/tests/private/response-test.ss
View File

@ -1,5 +1,7 @@
(module response-test mzscheme (module response-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "xml.ss" "xml")
(lib "file.ss")
(lib "response.ss" "web-server" "private") (lib "response.ss" "web-server" "private")
(lib "response-structs.ss" "web-server" "private") (lib "response-structs.ss" "web-server" "private")
(lib "connection-manager.ss" "web-server" "private") (lib "connection-manager.ss" "web-server" "private")
@ -25,7 +27,6 @@
#"Last-Modified: XXX GMT\r\n") #"Last-Modified: XXX GMT\r\n")
#"Date: XXX GMT\r\n")) #"Date: XXX GMT\r\n"))
; XXX
(define response-tests (define response-tests
(test-suite (test-suite
"HTTP Responses" "HTTP Responses"
@ -118,9 +119,150 @@
(output output-response (output output-response
`(html (head (title "Hey!")) (body "Content"))) `(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"))) #"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 (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 ; XXX
(test-suite (let ()
"output-file")))) (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"))))))