Rewriting response.ss and adding tests

svn: r6550
This commit is contained in:
Jay McCarthy 2007-06-09 01:32:11 +00:00
parent 7d7cae8bf2
commit e057ee856a
5 changed files with 135 additions and 209 deletions

View File

@ -337,6 +337,13 @@ needs. They are provided by @file{private/util.ss}.
@subsection{Exceptions}
@defproc[(pretty-print-invalid-xexpr [exn exn:invalid-xexpr?]
[v any/c])
void]{
Prints @scheme[v] as if it were almost an X-expression highlighting the error
according to @scheme[exn].
}
@; XXX Remove
@defproc[(network-error [s symbol?]
[fmt string?]

View File

@ -1,20 +1,17 @@
(module response mzscheme
(require (lib "contract.ss")
(lib "port.ss")
(lib "pretty.ss")
(lib "list.ss")
(lib "plt-match.ss")
(lib "xml.ss" "xml")
"connection-manager.ss"
"../private/response-structs.ss"
"util.ss")
; XXX Fix this insanity
; 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)])
[rename ext:output-response output-response (connection? response? . -> . void)]
[rename ext:output-response/method output-response/method (connection? response? symbol? . -> . void)]
[rename ext:output-file output-file (connection? path? symbol? bytes? integer? integer? . -> . void)])
;; Table 1. head responses:
; ------------------------------------------------------------------------------
@ -54,35 +51,99 @@
;; 2. In the case of a chunked response when close? = #f, then the response
;; must be compliant with http 1.0. In this case the chunked response is
;; simply turned into a non-chunked one.
(define (output-response conn resp)
(output-response/method conn resp 'get))
; XXX Check method in response
(define (output-response/method conn resp meth)
(define bresp (response->response/basic (connection-close? conn) resp))
(output-headers+response/basic conn bresp)
(unless (eq? meth 'head)
(output-response/basic conn bresp)))
(define (response->response/basic close? resp)
(cond
[(response/full? resp)
(make-response/full
(response/basic-code resp)
(response/basic-message resp)
(response/basic-seconds resp)
(response/basic-mime resp)
(list*
(cons 'Content-Length (number->string (response/full->size resp)))
(response/basic-extras resp))
(response/full-body resp))]
[(response/incremental? resp)
(if close?
resp
(make-response/incremental
(response/basic-code resp)
(response/basic-message resp)
(response/basic-seconds resp)
(response/basic-mime resp)
(list*
(cons 'Transfer-Encoding "chunked")
(response/basic-extras resp))
(response/incremental-generator resp)))]
[(and (pair? resp) (bytes? (car resp)))
(response->response/basic
close?
(make-response/full 200 "Okay" (current-seconds) (car resp) empty
(cdr resp)))]
[else
(response->response/basic
close?
(make-response/full 200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE empty
(list (xexpr->string resp))))]))
;; Write the headers portion of a response to an output port.
;; NOTE: According to RFC 2145 the server should write HTTP/1.1
;; header for *all* clients.
(define (output-headers+response/basic conn bresp)
(define o-port (connection-o-port conn))
(for-each (lambda (line)
(for-each (lambda (word) (display word o-port))
line)
(fprintf o-port "\r\n"))
(list* `("HTTP/1.1 " ,(response/basic-code bresp) " " ,(response/basic-message bresp))
`("Date: " ,(seconds->gmt-string (current-seconds)))
`("Last-Modified: " ,(seconds->gmt-string (response/basic-seconds bresp)))
`("Server: PLT Scheme")
`("Content-Type: " ,(response/basic-mime bresp))
(append (if (connection-close? conn)
`(("Connection: close"))
empty)
(extras->strings bresp))))
(fprintf o-port "\r\n"))
(define (output-response/basic conn bresp)
(define o-port (connection-o-port conn))
(match bresp
[(? response/full?)
(for-each
(lambda (str) (display str o-port))
(response/full-body bresp))]
[(? response/incremental?)
(if (connection-close? conn)
((response/incremental-generator bresp)
(lambda chunks
(for-each (lambda (chunk) (display chunk o-port)) chunks)))
(begin
((response/incremental-generator bresp)
(lambda chunks
(fprintf o-port "~x\r\n"
(apply + 0 (map data-length chunks)))
(for-each (lambda (chunk) (display chunk o-port)) chunks)
(fprintf o-port "\r\n")))
; one \r\n ends the last (empty) chunk and the second \r\n ends the (non-existant) trailers
(fprintf o-port "0\r\n\r\n")))]))
(define (data-length x)
(if (string? x)
(data-length (string->bytes/utf-8 x))
(bytes-length x)))
;;**************************************************
;; output-headers: connection number string (listof (listof String))
;; number string -> void
;; Write the headers portion of a response to an output port.
;; NOTE: According to RFC 2145 the server should write HTTP/1.1
;; header for *all* clients.
(define (output-headers conn code message extras seconds mime)
(let ([o-port (connection-o-port conn)])
(for-each
(lambda (line)
(for-each
(lambda (word) (display word o-port))
line)
(fprintf o-port "\r\n"))
(list* `("HTTP/1.1 " ,code " " ,message)
`("Date: " ,(seconds->gmt-string (current-seconds)))
`("Last-Modified: " ,(seconds->gmt-string seconds))
`("Server: PLT Scheme")
`("Content-Type: " ,mime)
(if (connection-close? conn)
(cons `("Connection: close") extras)
extras)))
(fprintf o-port "\r\n")))
; seconds->gmt-string : Nat -> String
; format is rfc1123 compliant according to rfc2068 (http/1.1)
(define (seconds->gmt-string s)
@ -122,83 +183,13 @@
(apply f conn args)
(flush-output (connection-o-port conn))))))))
;; **************************************************
;; output-response: connection response -> void
(define (output-response conn resp)
(cond
[(response/full? resp)
(output-response/basic
conn resp (response->size resp)
(lambda (o-port)
(for-each
(lambda (str) (display str o-port))
(response/full-body resp))))]
[(response/incremental? resp)
(output-response/incremental conn resp)]
[(and (pair? resp) (bytes? (car resp)))
(output-response/basic
conn
(make-response/basic 200 "Okay" (current-seconds) (car resp) '())
(response->size resp)
(lambda (o-port)
(for-each
(lambda (str) (display str o-port))
(cdr resp))))]
[else
; XXX: make a real exception for this.
(with-handlers
([exn:invalid-xexpr?
(lambda (exn)
(output-response/method
conn
(xexpr-exn->response exn resp)
'ignored))]
[exn? (lambda (exn)
(raise exn))])
; XXX Don't validate here
(let ([str (and (validate-xexpr resp) (xexpr->string resp))])
(output-response/basic
conn
(make-response/basic 200
"Okay"
(current-seconds)
TEXT/HTML-MIME-TYPE
'())
(add1 (data-length str))
(lambda (o-port)
(display str o-port)
(newline o-port)))))]))
(define ext:output-response
(ext:wrap output-response))
;; 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)))))]))
;; response/full->size: response/full -> number
(define (response/full->size resp)
(apply + (map data-length (response/full-body resp))))
;; **************************************************
;; output-file: connection path symbol bytes integer integer -> void
(define (output-file conn file-path method mime-type
start end-or-inf)
@ -207,11 +198,11 @@
total-len
end-or-inf))
(define len (- end start))
(output-headers conn 206 "Okay"
`(("Content-Length: " ,len)
("Content-Range: " ,(format "bytes ~a-~a/~a" start end total-len)))
(file-or-directory-modify-seconds file-path)
mime-type)
(define bresp
(make-response/basic 206 "Okay" (file-or-directory-modify-seconds file-path) mime-type
(list (cons 'Content-Length (number->string len))
(cons 'Content-Range (format "bytes ~a-~a/~a" start end total-len)))))
(output-headers+response/basic conn bresp)
(when (eq? method 'get)
; Give it one second per byte.
(adjust-connection-timeout! conn len)
@ -225,103 +216,13 @@
(define ext:output-file
(ext:wrap output-file))
; XXX Check method in response
;; **************************************************
;; output-response/method: connection response/full symbol -> void
;; If it is a head request output headers only, otherwise output as usual
(define (output-response/method conn resp meth)
(cond
[(eqv? meth 'head)
(output-headers/response conn resp
`(("Content-Length: "
,(response->size resp))))]
[else
(output-response conn resp)]))
(define ext:output-response/method
(ext:wrap output-response/method))
;; **************************************************
;; output-headers/response: connection response (listof (listof string)) -> void
;; Write the headers for a response to an output port
(define (output-headers/response conn resp extras)
(output-headers conn
(response/basic-code resp)
(response/basic-message resp)
(append extras (extras->strings resp))
(response/basic-seconds resp)
(response/basic-mime resp)))
;; **************************************************
;; output-response/basic: connection response number (o-port -> void) -> void
;; Write a normal response to an output port
(define (output-response/basic conn resp size responder)
(output-headers/response conn resp
`(("Content-Length: " ,size)))
(responder (connection-o-port conn)))
;; **************************************************
;; output-response/incremental: connection response/incremental -> void
;; Write a chunked response to an output port.
(define (output-response/incremental conn resp/inc)
(let ([o-port (connection-o-port conn)])
(cond
[(connection-close? conn)
(output-headers/response conn resp/inc '())
((response/incremental-generator resp/inc)
(lambda chunks
(for-each (lambda (chunk) (display chunk o-port)) chunks)))]
[else
(output-headers/response conn resp/inc
`(("Transfer-Encoding: chunked")))
((response/incremental-generator resp/inc)
(lambda chunks
(fprintf o-port "~x\r\n"
(apply + 0 (map data-length chunks)))
(for-each (lambda (chunk) (display chunk o-port)) chunks)
(fprintf o-port "\r\n")))
; one \r\n ends the last (empty) chunk and the second \r\n ends the (non-existant) trailers
(fprintf o-port "0\r\n\r\n")])))
;; extras->strings: response/basic -> (listof (listof string))
;; convert the response/basic-extras to the form used by output-headers
(define (extras->strings r/bas)
(map
(lambda (xtra)
(list (symbol->string (car xtra)) ": " (cdr xtra)))
(response/basic-extras r/bas)))
;; Turn an exn:invalid-xexpr into a response.
(define (xexpr-exn->response exn x)
(make-response/full
500 "Servlet Error"
(current-seconds)
#"text/html"
'()
(list
(string-append
"<html><head><title>Erroneous Xexpr</title></head>"
"<body><h1>Erroneous Xexpr</h1>"
"<p>An Xexpr in the servlet is malformed. The exact error is</p>"
"<pre>" (exn-message exn) "</pre>"
"<h2>The Full Xexpr Is</h2>"
"<pre>"
(let ([o (open-output-string)])
(parameterize ([current-output-port o])
(pretty-print-invalid-xexpr exn x))
(get-output-string o))
"</pre>"))))
(define (pretty-print-invalid-xexpr exn xexpr)
(define code (exn:invalid-xexpr-code exn))
(parameterize ([pretty-print-size-hook (lambda (v display? out)
(and (equal? v code)
(string-length (format (if display? "~a" "~v") v))))]
[pretty-print-print-hook (lambda (v display? out)
(fprintf out
(string-append
"<font color=\"red\">"
(if display? "~a" "~v")
"</font>")
v))])
(pretty-print xexpr))))
(response/basic-extras r/bas))))

View File

@ -4,8 +4,11 @@
(lib "contract.ss")
(lib "string.ss")
(lib "serialize.ss")
(lib "pretty.ss")
(lib "xml.ss" "xml")
(lib "url.ss" "net"))
(provide/contract
[pretty-print-invalid-xexpr (exn:invalid-xexpr? any/c . -> . void)]
[url-replace-path ((list? . -> . list?) url? . -> . url?)]
[explode-path* (path? . -> . (listof (or/c symbol? path?)))]
[path-without-base (path? path? . -> . list?)]
@ -21,6 +24,20 @@
[read/string (string? . -> . serializable?)]
[write/string (serializable? . -> . string?)])
(define (pretty-print-invalid-xexpr exn xexpr)
(define code (exn:invalid-xexpr-code exn))
(parameterize ([pretty-print-size-hook (lambda (v display? out)
(and (equal? v code)
(string-length (format (if display? "~a" "~v") v))))]
[pretty-print-print-hook (lambda (v display? out)
(fprintf out
(string-append
"<font color=\"red\">"
(if display? "~a" "~v")
"</font>")
v))])
(pretty-print xexpr)))
(define (read/string str)
(read (open-input-string str)))
(define (write/string v)

View File

@ -118,7 +118,7 @@
(test-equal? "any"
(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")))
#"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: 65\r\n\r\n<html><head><title>Hey!</title></head><body>Content</body></html>")))
(test-suite
"output-response/method"
(test-suite
@ -160,35 +160,35 @@
(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")
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\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")
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\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")
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\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")
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\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")
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\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"
@ -197,7 +197,7 @@
(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"))
#"HTTP/1.1 404 404\r\nDate: XXX GMT\r\nLast-Modified: XXX GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\nHeader: Value\r\n\r\n"))
(test-suite
"Simple content"
(test-equal? "empty"
@ -221,8 +221,7 @@
(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
#"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: 65\r\n\r\n")))
(let ()
(define tmp-file (make-temporary-file))
(with-output-to-file tmp-file

View File

@ -8,6 +8,8 @@
(test-suite
"Utilities"
; XXX test pretty-print-invalid-xexpr
(test-suite
"url-replace-path"
(test-case