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

prefer bytes

Browse Source 
svn: r13377
This commit is contained in:
Jay McCarthy 2009-02-03 16:23:28 +00:00
parent a2537d7dc9
commit 7f13cb3da8
17 changed files with 226 additions and 208 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/handin-server/web-status-server.ss
View File

@ -181,7 +181,7 @@
[html? (regexp-match? #rx"[.]html?$" (string-foldcase tag))]
[wxme? (regexp-match?
#rx#"^(?:#reader[(]lib\"read.ss\"\"wxme\"[)])?WXME" data)])
(make-response/full 200 "Okay" (current-seconds)
(make-response/full 200 #"Okay" (current-seconds)
(cond [html? #"text/html"]
[wxme? #"application/data"]
[else #"text/plain"])

28
collects/tests/web-server/dispatchers/dispatch-files-test.ss
View File

@ -62,46 +62,46 @@
(list (cons 1 10) (cons 20 #f) (cons #f 30)))
(test-equal? "file, exists, whole, no Range, get"
(collect (dispatch #t tmp-file) (req #f 'get empty))
(collect (dispatch #t tmp-file) (req #f #"GET" empty))
#"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
(test-equal? "file, exists, whole, no Range, head"
(collect (dispatch #t tmp-file) (req #f 'head empty))
(collect (dispatch #t tmp-file) (req #f #"HEAD" empty))
#"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\n")
(test-equal? "file, exists, whole, Range, get"
(collect (dispatch #t tmp-file) (req #f 'get (list (make-header #"Range" #"bytes=0-80"))))
(collect (dispatch #t tmp-file) (req #f #"GET" (list (make-header #"Range" #"bytes=0-80"))))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
(test-equal? "file, exists, whole, Range, head"
(collect (dispatch #t tmp-file) (req #f 'head (list (make-header #"Range" #"bytes=0-80"))))
(collect (dispatch #t tmp-file) (req #f #"HEAD" (list (make-header #"Range" #"bytes=0-80"))))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n")
(test-equal? "file, exists, part, get"
(collect (dispatch #t tmp-file) (req #f 'get (list (make-header #"Range" #"bytes=5-9"))))
(collect (dispatch #t tmp-file) (req #f #"GET" (list (make-header #"Range" #"bytes=5-9"))))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 5\r\nContent-Range: bytes 5-9/81\r\n\r\n><hea")
(test-equal? "file, exists, part, head"
(collect (dispatch #t tmp-file) (req #f 'head (list (make-header #"Range" #"bytes=5-9"))))
(collect (dispatch #t tmp-file) (req #f #"HEAD" (list (make-header #"Range" #"bytes=5-9"))))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 5\r\nContent-Range: bytes 5-9/81\r\n\r\n")
(test-exn "path, non"
exn:dispatcher?
(lambda () (collect (dispatch #t not-there) (req #f 'get empty))))
(lambda () (collect (dispatch #t not-there) (req #f #"GET" empty))))
(test-equal? "dir, exists, no Range, get"
(collect (dispatch #t a-dir) (req #t 'get empty))
(collect (dispatch #t a-dir) (req #t #"GET" empty))
#"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
(test-equal? "dir, exists, no Range, head"
(collect (dispatch #t a-dir) (req #t 'head empty))
(collect (dispatch #t a-dir) (req #t #"HEAD" empty))
#"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\n")
(test-equal? "dir, exists, Range, get"
(collect (dispatch #t a-dir) (req #t 'get (list (make-header #"Range" #"bytes=0-80"))))
(collect (dispatch #t a-dir) (req #t #"GET" (list (make-header #"Range" #"bytes=0-80"))))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
(test-equal? "dir, exists, Range, head"
(collect (dispatch #t a-dir) (req #t 'head (list (make-header #"Range" #"bytes=0-80"))))
(collect (dispatch #t a-dir) (req #t #"HEAD" (list (make-header #"Range" #"bytes=0-80"))))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\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))
(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: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\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))))
(lambda () (collect (dispatch #f a-dir) (req #t #"GET" empty))))
(test-exn "dir, not exists, head"
exn:dispatcher?
(lambda () (collect (dispatch #f a-dir) (req #t 'head empty))))))
(lambda () (collect (dispatch #f a-dir) (req #t #"HEAD" empty))))))

2
collects/tests/web-server/dispatchers/dispatch-passwords-test.ss
View File

@ -42,7 +42,7 @@
#:authentication-responder
(lambda (u h) (esc h))))
(define-values (c i o) (make-mock-connection #""))
(d c (make-request 'get
(d c (make-request #"GET"
(if applies?
(string->url "http://host/secret/something")
(string->url "http://host/not-secret"))

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

@ -21,38 +21,35 @@
(apply f c any)
(redact (get-output-bytes o)))
(define response-tests
(define output-response-tests
(test-suite
"HTTP Responses"
(test-suite
"output-response"
(test-suite
"response/basic"
(test-equal? "response/basic"
(output output-response
(make-response/basic 404 "404" (current-seconds) #"text/html"
(make-response/basic 404 #"404" (current-seconds) #"text/html"
(list)))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n")
(test-equal? "response/basic (header)"
(output output-response
(make-response/basic 404 "404" (current-seconds) #"text/html"
(make-response/basic 404 #"404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value"))))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\nHeader: Value\r\n\r\n")
(test-equal? "response/basic (body)"
(output output-response
(make-response/basic 404 "404" (current-seconds) #"text/html"
(make-response/basic 404 #"404" (current-seconds) #"text/html"
(list)))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n")
(test-equal? "response/basic (bytes body)"
(output output-response
(make-response/basic 404 "404" (current-seconds) #"text/html"
(make-response/basic 404 #"404" (current-seconds) #"text/html"
(list)))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n")
(test-equal? "response/basic (both)"
(output output-response
(make-response/basic 404 "404" (current-seconds) #"text/html"
(make-response/basic 404 #"404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value"))))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\nHeader: Value\r\n\r\n"))
@ -60,68 +57,64 @@
"response/full"
(test-equal? "response/full"
(output output-response
(make-response/full 404 "404" (current-seconds) #"text/html"
(make-response/full 404 #"404" (current-seconds) #"text/html"
(list) (list)))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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
(make-response/full 404 "404" (current-seconds) #"text/html"
(make-response/full 404 #"404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value")) (list)))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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
(make-response/full 404 "404" (current-seconds) #"text/html"
(list) (list "Content!")))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 8\r\n\r\nContent!")
(test-equal? "response/full (bytes body)"
(output output-response
(make-response/full 404 "404" (current-seconds) #"text/html"
(make-response/full 404 #"404" (current-seconds) #"text/html"
(list) (list #"Content!")))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 8\r\n\r\nContent!")
(test-equal? "response/full (both)"
(output output-response
(make-response/full 404 "404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value")) (list "Content!")))
(make-response/full 404 #"404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value")) (list #"Content!")))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 8\r\nHeader: Value\r\n\r\nContent!"))
(test-suite
"response/incremental"
(test-equal? "response/incremental"
(output output-response
(make-response/incremental 404 "404" (current-seconds) #"text/html"
(make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list) (lambda (write) (void))))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\n\r\n0\r\n\r\n")
(test-equal? "response/incremental (header)"
(output output-response
(make-response/incremental 404 "404" (current-seconds) #"text/html"
(make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value"))
(lambda (write) (void))))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\nHeader: Value\r\n\r\n0\r\n\r\n")
(test-equal? "response/incremental (body)"
(output output-response
(make-response/incremental 404 "404" (current-seconds) #"text/html"
(make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list)
(lambda (write) (write "Content!"))))
(lambda (write) (write #"Content!"))))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\n\r\n8\r\nContent!\r\n0\r\n\r\n")
(test-equal? "response/incremental (bytes body)"
(output output-response
(make-response/incremental 404 "404" (current-seconds) #"text/html"
(make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list)
(lambda (write) (write #"Content!"))))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\n\r\n8\r\nContent!\r\n0\r\n\r\n")
(test-equal? "response/incremental (both)"
(output output-response
(make-response/incremental 404 "404" (current-seconds) #"text/html"
(make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value"))
(lambda (write) (write "Content!"))))
(lambda (write) (write #"Content!"))))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\nHeader: Value\r\n\r\n8\r\nContent!\r\n0\r\n\r\n")
(test-equal? "response/incremental (twice)"
(output output-response
(make-response/incremental 404 "404" (current-seconds) #"text/html"
(make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value"))
(lambda (write)
(write "Content!")
(write "Content!"))))
(write #"Content!")
(write #"Content!"))))
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\nHeader: Value\r\n\r\n8\r\nContent!\r\n8\r\nContent!\r\n0\r\n\r\n"))
(test-suite
@ -145,87 +138,89 @@
(output output-response
`(html (head (title "Hey!")) (body "Content")))
#"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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
))
(define output-response/method-tests
(test-suite
"output-response/method"
(test-suite
"response/full"
(test-equal? "response/full"
(output output-response/method
(make-response/full 404 "404" (current-seconds) #"text/html"
(make-response/full 404 #"404" (current-seconds) #"text/html"
(list) (list))
'head)
#"HEAD")
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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"
(make-response/full 404 #"404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value")) (list))
'head)
#"HEAD")
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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)
(make-response/full 404 #"404" (current-seconds) #"text/html"
(list) (list #"Content!"))
#"HEAD")
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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"
(make-response/full 404 #"404" (current-seconds) #"text/html"
(list) (list #"Content!"))
'head)
#"HEAD")
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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 (make-header #"Header" #"Value")) (list "Content!"))
'head)
(make-response/full 404 #"404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value")) (list #"Content!"))
#"HEAD")
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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"
(make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list) (lambda (write) (void)))
'head)
#"HEAD")
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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"
(make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value"))
(lambda (write) (void)))
'head)
#"HEAD")
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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"
(make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list)
(lambda (write) (write "Content!")))
'head)
(lambda (write) (write #"Content!")))
#"HEAD")
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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"
(make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list)
(lambda (write) (write #"Content!")))
'head)
#"HEAD")
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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"
(make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value"))
(lambda (write) (write "Content!")))
'head)
(lambda (write) (write #"Content!")))
#"HEAD")
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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"
(make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list (make-header #"Header" #"Value"))
(lambda (write)
(write "Content!")
(write "Content!")))
'head)
(write #"Content!")
(write #"Content!")))
#"HEAD")
#"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\nHeader: Value\r\n\r\n"))
(test-suite
@ -233,17 +228,17 @@
(test-equal? "empty"
(output output-response/method
(list #"text/html")
'head)
#"HEAD")
#"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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)
(list #"text/html" #"Content")
#"HEAD")
#"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED 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)
#"HEAD")
#"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 7\r\n\r\n"))
(test-suite
@ -251,8 +246,17 @@
(test-equal? "any"
(output output-response/method
`(html (head (title "Hey!")) (body "Content"))
'head)
#"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nContent-Length: 65\r\n\r\n")))
#"HEAD")
#"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nContent-Length: 65\r\n\r\n"))))
(define response-tests
(test-suite
"HTTP Responses"
output-response-tests
output-response/method-tests
(let ()
(define tmp-file (make-temporary-file))
(with-output-to-file tmp-file
@ -274,75 +278,75 @@
"output-file"
(test-equal? "(get) whole file - no Range header"
(output output-file tmp-file 'get #"text/html" #f)
(output output-file tmp-file #"GET" #"text/html" #f)
#"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
(test-equal? "(get) whole file - Range header present"
(output output-file tmp-file 'get #"text/html" '((0 . 80)))
(output output-file tmp-file #"GET" #"text/html" '((0 . 80)))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
(test-equal? "(get) single range - suffix range larger than file"
(output output-file tmp-file 'get #"text/html" '((#f . 90)))
(output output-file tmp-file #"GET" #"text/html" '((#f . 90)))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
(test-equal? "(get) single range - 10 bytes from the start"
(output output-file tmp-file 'get #"text/html" '((0 . 9)))
(output output-file tmp-file #"GET" #"text/html" '((0 . 9)))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 10\r\nContent-Range: bytes 0-9/81\r\n\r\n<html><hea")
(test-equal? "(get) single range - 10 bytes from the end"
(output output-file tmp-file 'get #"text/html" '((71 . #f)))
(output output-file tmp-file #"GET" #"text/html" '((71 . #f)))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 10\r\nContent-Range: bytes 71-80/81\r\n\r\ndy></html>")
(test-equal? "(get) single range - 10 bytes from past the end"
(output output-file tmp-file 'get #"text/html" '((76 . 86)))
(output output-file tmp-file #"GET" #"text/html" '((76 . 86)))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 5\r\nContent-Range: bytes 76-80/81\r\n\r\nhtml>")
(test-equal? "(get) single range - 10 bytes from the middle"
(output output-file tmp-file 'get #"text/html" '((10 . 19)))
(output output-file tmp-file #"GET" #"text/html" '((10 . 19)))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 10\r\nContent-Range: bytes 10-19/81\r\n\r\nd><title>A")
(test-equal? "(get) multiple ranges"
(output output-file/boundary tmp-file 'get #"text/html" '((10 . 19) (30 . 39) (50 . 59)) #"BOUNDARY")
(output output-file/boundary tmp-file #"GET" #"text/html" '((10 . 19) (30 . 39) (50 . 59)) #"BOUNDARY")
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: multipart/byteranges; boundary=BOUNDARY\r\nAccept-Ranges: bytes\r\nContent-Length: 260\r\n\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 10-19/81\r\n\r\nd><title>A\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 30-39/81\r\n\r\ntle></head\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 50-59/81\r\n\r\ne's some c\r\n--BOUNDARY--\r\n")
(test-equal? "(get) some bad ranges"
(output output-file/boundary tmp-file 'get #"text/html" '((10 . 19) (1000 . 1050) (30 . 39) (50 . 49)) #"BOUNDARY")
(output output-file/boundary tmp-file #"GET" #"text/html" '((10 . 19) (1000 . 1050) (30 . 39) (50 . 49)) #"BOUNDARY")
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: multipart/byteranges; boundary=BOUNDARY\r\nAccept-Ranges: bytes\r\nContent-Length: 178\r\n\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 10-19/81\r\n\r\nd><title>A\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 30-39/81\r\n\r\ntle></head\r\n--BOUNDARY--\r\n")
(test-equal? "(get) all bad ranges"
(output output-file/boundary tmp-file 'get #"text/html" '((-10 . -5) (1000 . 1050) (50 . 49)) #"BOUNDARY")
(output output-file/boundary tmp-file #"GET" #"text/html" '((-10 . -5) (1000 . 1050) (50 . 49)) #"BOUNDARY")
#"HTTP/1.1 416 Invalid range request\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\n\r\n")
(test-equal? "(head) whole file - no Range header"
(output output-file tmp-file 'head #"text/html" #f)
(output output-file tmp-file #"HEAD" #"text/html" #f)
#"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\n")
(test-equal? "(head) whole file - Range header present"
(output output-file tmp-file 'head #"text/html" '((0 . 80)))
(output output-file tmp-file #"HEAD" #"text/html" '((0 . 80)))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n")
(test-equal? "(head) single range - 10 bytes from the start"
(output output-file tmp-file 'head #"text/html" '((0 . 9)))
(output output-file tmp-file #"HEAD" #"text/html" '((0 . 9)))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 10\r\nContent-Range: bytes 0-9/81\r\n\r\n")
(test-equal? "(head) single range - 10 bytes from the end"
(output output-file tmp-file 'head #"text/html" '((71 . #f)))
(output output-file tmp-file #"HEAD" #"text/html" '((71 . #f)))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 10\r\nContent-Range: bytes 71-80/81\r\n\r\n")
(test-equal? "(head) single range - 10 bytes from the middle"
(output output-file tmp-file 'head #"text/html" '((10 . 19)))
(output output-file tmp-file #"HEAD" #"text/html" '((10 . 19)))
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 10\r\nContent-Range: bytes 10-19/81\r\n\r\n")
(test-equal? "(head) multiple ranges"
(output output-file/boundary tmp-file 'head #"text/html" '((10 . 19) (30 . 39) (50 . 59)) #"BOUNDARY")
(output output-file/boundary tmp-file #"HEAD" #"text/html" '((10 . 19) (30 . 39) (50 . 59)) #"BOUNDARY")
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: multipart/byteranges; boundary=BOUNDARY\r\nAccept-Ranges: bytes\r\nContent-Length: 260\r\n\r\n")
(test-equal? "(head) some bad ranges"
(output output-file/boundary tmp-file 'head #"text/html" '((10 . 19) (1000 . 1050) (30 . 39) (50 . 49)) #"BOUNDARY")
(output output-file/boundary tmp-file #"HEAD" #"text/html" '((10 . 19) (1000 . 1050) (30 . 39) (50 . 49)) #"BOUNDARY")
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: multipart/byteranges; boundary=BOUNDARY\r\nAccept-Ranges: bytes\r\nContent-Length: 178\r\n\r\n")
(test-equal? "(head) all bad ranges"
(output output-file/boundary tmp-file 'head #"text/html" '((-10 . -5) (1000 . 1050) (50 . 49)) #"BOUNDARY")
(output output-file/boundary tmp-file #"HEAD" #"text/html" '((-10 . -5) (1000 . 1050) (50 . 49)) #"BOUNDARY")
#"HTTP/1.1 416 Invalid range request\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\n\r\n")
))))

12
collects/tests/web-server/servlet/bindings-test.ss
View File

@ -17,21 +17,21 @@
(test-case
"Simple"
(check-equal? (request-bindings
(make-request 'get (string->url "http://test.com/foo")
(make-request #"GET" (string->url "http://test.com/foo")
empty (list (make-binding:form #"key" #"val")) #f
"host" 80 "client"))
'((key . "val"))))
(test-case
"Case"
(check-equal? (request-bindings
(make-request 'get (string->url "http://test.com/foo")
(make-request #"GET" (string->url "http://test.com/foo")
empty (list (make-binding:form #"KEY" #"val")) #f
"host" 80 "client"))
'((key . "val"))))
(test-case
"Multi"
(check-equal? (request-bindings
(make-request 'get (string->url "http://test.com/foo")
(make-request #"GET" (string->url "http://test.com/foo")
empty (list (make-binding:form #"key" #"val")
(make-binding:form #"key2" #"val")) #f
"host" 80 "client"))
@ -40,7 +40,7 @@
(test-case
"File"
(check-equal? (request-bindings
(make-request 'get (string->url "http://test.com/foo")
(make-request #"GET" (string->url "http://test.com/foo")
empty (list (make-binding:file #"key" #"file" empty #"val")) #f
"host" 80 "client"))
'((key . #"val")))))
@ -50,14 +50,14 @@
(test-case
"Simple"
(check-equal? (request-headers
(make-request 'get (string->url "http://test.com/foo")
(make-request #"GET" (string->url "http://test.com/foo")
(list (make-header #"key" #"val")) empty #f
"host" 80 "client"))
'((key . "val"))))
(test-case
"Case"
(check-equal? (request-headers
(make-request 'get (string->url "http://test.com/foo")
(make-request #"GET" (string->url "http://test.com/foo")
(list (make-header #"KEY" #"val")) empty #f
"host" 80 "client"))
'((key . "val")))))

4
collects/tests/web-server/servlet/helpers-test.ss
View File

@ -29,13 +29,13 @@
302)
(test-equal? "Message (temp)"
(response/basic-message (redirect-to "http://test.com/foo"))
"Moved Temporarily")
#"Moved Temporarily")
(test-equal? "Code"
(response/basic-code (redirect-to "http://test.com/foo" permanently))
301)
(test-equal? "Message"
(response/basic-message (redirect-to "http://test.com/foo" permanently))
"Moved Permanently")
#"Moved Permanently")
(test-equal? "URL"
(dehead (response/basic-headers (redirect-to "http://test.com/foo")))
(list (list #"Location" #"http://test.com/foo")))

2
collects/tests/web-server/util.ss
View File

@ -18,7 +18,7 @@
call)
(define (call d u bs)
(htxml (collect d (make-request 'get (string->url u) empty bs #"" "127.0.0.1" 80 "127.0.0.1"))))
(htxml (collect d (make-request #"GET" (string->url u) empty bs #"" "127.0.0.1" 80 "127.0.0.1"))))
(define (htxml bs)
(match (regexp-match #"^.+\r\n\r\n(.+)$" bs)
[(list _ s)

2
collects/web-server/dispatchers/dispatch-log.ss
View File

@ -42,7 +42,7 @@
(define (request-line-raw req)
(format "~a ~a HTTP/1.1"
(string-upcase (symbol->string (request-method req)))
(string-upcase (bytes->string/utf-8 (request-method req)))
(url->string (request-uri req))))
(define (apache-default-format req)
(define request-time (srfi-date:current-date))

2
collects/web-server/formlets/date.ss
View File

@ -45,7 +45,7 @@
(require net/url
web-server/servlet)
(formlet-process travel-formlet
(make-request 'get (string->url "http://test.com")
(make-request #"GET" (string->url "http://test.com")
empty
(list (make-binding:form #"input_0" #"Jay")
(make-binding:form #"input_1" #"10")

8
collects/web-server/http/redirect.ss
View File

@ -3,12 +3,12 @@
(require web-server/http/response-structs
web-server/http/request-structs)
; redirection-status = (make-redirection-status nat str)
; redirection-status = (make-redirection-status nat bytes)
(define-struct redirection-status (code message))
(define permanently (make-redirection-status 301 "Moved Permanently"))
(define temporarily (make-redirection-status 302 "Moved Temporarily"))
(define see-other (make-redirection-status 303 "See Other"))
(define permanently (make-redirection-status 301 #"Moved Permanently"))
(define temporarily (make-redirection-status 302 #"Moved Temporarily"))
(define see-other (make-redirection-status 303 #"See Other"))
; : str [redirection-status] -> response
(define(redirect-to

12
collects/web-server/http/request-structs.ss
View File

@ -2,11 +2,8 @@
(require mzlib/contract
mzlib/serialize
mzlib/plt-match
net/url)
(define (bytes-ci=? b0 b1)
(string-ci=? (bytes->string/utf-8 b0)
(bytes->string/utf-8 b1)))
net/url
web-server/private/util)
(define-serializable-struct header (field value))
(define (headers-assq* f hs)
@ -52,10 +49,9 @@
[headers (listof header?)]
[content bytes?])])
(define-serializable-struct request (method uri headers/raw bindings/raw post-data/raw
host-ip host-port client-ip))
(define-serializable-struct request (method uri headers/raw bindings/raw post-data/raw host-ip host-port client-ip))
(provide/contract
[struct request ([method symbol?]
[struct request ([method bytes?]
[uri url?]
[headers/raw (listof header?)]
[bindings/raw (listof binding?)]

6
collects/web-server/http/request.ss
View File

@ -87,7 +87,7 @@
(let ([rx (byte-regexp #"^([^ ]+) (.+) HTTP/([0-9]+)\\.([0-9]+)$")])
(lambda (a) (regexp-match rx a))))
; read-request-line : iport -> symbol url number number
; read-request-line : iport -> bytes url number number
; to read in the first line of an http request, AKA the "request line"
; effect: in case of errors, complain [MF: where] and close the ports
(define (read-request-line ip)
@ -98,7 +98,7 @@
[(match-method line)
=> (match-lambda
[(list _ method url major minor)
(values (lowercase-symbol! (bytes->string/utf-8 method))
(values method
(string->url (bytes->string/utf-8 url))
(string->number (bytes->string/utf-8 major))
(string->number (bytes->string/utf-8 minor)))])]
@ -110,7 +110,7 @@
(let ([rx (byte-regexp (bytes-append #"^([^:]*):[ " (bytes 9) #"]*(.*)"))])
(lambda (a) (regexp-match rx a))))
; read-headers : iport -> (listof (cons symbol bytes))
; read-headers : iport -> (listof header?)
(define (read-headers in)
(let read-header ()
(define l (read-bytes-line in 'any))

76
collects/web-server/http/response-structs.ss
View File

@ -1,5 +1,6 @@
#lang scheme/base
(require mzlib/contract
scheme/list
xml/xml
web-server/http/request-structs)
@ -9,35 +10,90 @@
(define-struct (response/full response/basic) (body))
(define-struct (response/incremental response/basic) (generator))
; response = (cons string (listof string)), where the first string is a mime-type
; | x-expression
; | response/basic
(define response/c
(or/c response/basic?
(listof (or/c string? bytes?))
(cons/c bytes? (listof (or/c string? bytes?)))
xexpr/c))
;; response/full->size: response/full -> number
(define (response/full->size resp)
(apply + (map bytes-length (response/full-body resp))))
(define (normalize-response 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* (make-header #"Content-Length" (string->bytes/utf-8 (number->string (response/full->size resp))))
(response/basic-headers 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* (make-header #"Transfer-Encoding" #"chunked")
(response/basic-headers resp))
(response/incremental-generator resp)))]
[(response/basic? resp)
(normalize-response
close?
(make-response/full
(response/basic-code resp)
(response/basic-message resp)
(response/basic-seconds resp)
(response/basic-mime resp)
(response/basic-headers resp)
empty))]
[(and (list? resp)
(not (empty? resp))
(bytes? (first resp))
(andmap (lambda (i) (or (string? i)
(bytes? i)))
(rest resp)))
(normalize-response
close?
(make-response/full
200 #"Okay" (current-seconds) (car resp) empty
(map (lambda (bs)
(if (string? bs)
(string->bytes/utf-8 bs)
bs))
(rest resp))))]
[else
(normalize-response
close?
(make-response/full
200 #"Okay" (current-seconds) TEXT/HTML-MIME-TYPE empty
(list (string->bytes/utf-8 (xexpr->string resp)))))]))
(provide/contract
[struct response/basic
([code number?]
[message string?]
[message bytes?]
[seconds number?]
[mime bytes?]
[headers (listof header?)])]
[struct (response/full response/basic)
([code number?]
[message string?]
[message bytes?]
[seconds number?]
[mime bytes?]
[headers (listof header?)]
[body (listof (or/c string?
bytes?))])]
[body (listof bytes?)])]
[struct (response/incremental response/basic)
([code number?]
[message string?]
[message bytes?]
[seconds number?]
[mime bytes?]
[headers (listof header?)]
[generator ((() (listof (or/c bytes? string?)) . ->* . any) . -> . any)])]
[generator ((() (listof bytes?) . ->* . any) . -> . any)])]
[response/c contract?]
[normalize-response (boolean? response/c . -> . (or/c response/full? response/incremental?))]
[TEXT/HTML-MIME-TYPE bytes?])

74
collects/web-server/http/response.ss
View File

@ -14,8 +14,8 @@
(provide/contract
[rename ext:output-response output-response (connection? response/c . -> . void)]
[rename ext:output-response/method output-response/method (connection? response/c symbol? . -> . void)]
[rename ext:output-file output-file (connection? path-string? symbol? bytes? (or/c pair? false/c) . -> . void)])
[rename ext:output-response/method output-response/method (connection? response/c bytes? . -> . void)]
[rename ext:output-file output-file (connection? path-string? bytes? bytes? (or/c pair? false/c) . -> . void)])
;; Table 1. head responses:
; ------------------------------------------------------------------------------
@ -56,57 +56,14 @@
;; simply turned into a non-chunked one.
(define (output-response conn resp)
(output-response/method conn resp 'get))
(output-response/method conn resp #"GET"))
(define (output-response/method conn resp meth)
(define bresp (response->response/basic (connection-close? conn) resp))
(define bresp (normalize-response (connection-close? conn) resp))
(output-headers+response/basic conn bresp)
(unless (eq? meth 'head)
(unless (bytes-ci=? 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* (make-header #"Content-Length" (string->bytes/utf-8 (number->string (response/full->size resp))))
(response/basic-headers 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* (make-header #"Transfer-Encoding" #"chunked")
(response/basic-headers resp))
(response/incremental-generator resp)))]
[(response/basic? resp)
(response->response/basic
close?
(make-response/full
(response/basic-code resp)
(response/basic-message resp)
(response/basic-seconds resp)
(response/basic-mime resp)
(response/basic-headers resp)
empty))]
[(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.
@ -154,17 +111,12 @@
((response/incremental-generator bresp)
(lambda chunks
(fprintf o-port "~x\r\n"
(apply + 0 (map data-length chunks)))
(apply + 0 (map bytes-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)))
; seconds->gmt-string : Nat -> String
; format is rfc1123 compliant according to rfc2068 (http/1.1)
(define (seconds->gmt-string s)
@ -203,10 +155,6 @@
(define ext:output-response
(ext:wrap output-response))
;; response/full->size: response/full -> number
(define (response/full->size resp)
(apply + (map data-length (response/full-body resp))))
;; output-file: connection
;; path
;; symbol
@ -305,7 +253,7 @@
(make-206-response modified-seconds mime-type total-content-length total-file-length converted-ranges boundary)
(make-200-response modified-seconds mime-type total-content-length)))
; Send the appropriate file content:
(when (eq? method 'get)
(when (bytes-ci=? method #"GET")
(adjust-connection-timeout! ; Give it one second per byte.
conn
(apply + (map (lambda (range)
@ -407,14 +355,14 @@
(let ([start (caar converted-ranges)]
[end (cdar converted-ranges)])
(make-response/basic
206 "Partial content"
206 #"Partial content"
modified-seconds
mime-type
(list (make-header #"Accept-Ranges" #"bytes")
(make-content-length-header total-content-length)
(make-content-range-header start end total-file-length))))
(make-response/basic
206 "Partial content"
206 #"Partial content"
modified-seconds
(bytes-append #"multipart/byteranges; boundary=" boundary)
(list (make-header #"Accept-Ranges" #"bytes")
@ -423,7 +371,7 @@
;; make-200-response : integer bytes integer -> basic-response
(define (make-200-response modified-seconds mime-type total-content-length)
(make-response/basic
200 "OK"
200 #"OK"
modified-seconds
mime-type
(list (make-header #"Accept-Ranges" #"bytes")
@ -432,7 +380,7 @@
;; make-416-response : integer bytes -> basic-response
(define (make-416-response modified-seconds mime-type)
(make-response/basic
416 "Invalid range request"
416 #"Invalid range request"
modified-seconds
mime-type
null))

7
collects/web-server/private/util.ss
View File

@ -26,7 +26,12 @@
[read/string (string? . -> . serializable?)]
[write/string (serializable? . -> . string?)]
[read/bytes (bytes? . -> . serializable?)]
[write/bytes (serializable? . -> . bytes?)])
[write/bytes (serializable? . -> . bytes?)]
[bytes-ci=? (bytes? bytes? . -> . boolean?)])
(define (bytes-ci=? b0 b1)
(string-ci=? (bytes->string/utf-8 b0)
(bytes->string/utf-8 b1)))
(define (read/string str)
(read (open-input-string str)))

23
collects/web-server/scribblings/http.scrbl
View File

@ -55,7 +55,7 @@ The @web-server implements many HTTP RFCs that are provided by this module.
Returns the binding with an id equal to @scheme[id] from @scheme[binds] or @scheme[#f].
}
@defstruct[request ([method symbol?]
@defstruct[request ([method bytes?]
[uri url?]
[headers/raw (listof header?)]
[bindings/raw (listof binding?)]
@ -158,7 +158,7 @@ Here is an example typical of what you will find in many applications:
@defstruct[response/basic
([code number?]
[message string?]
[message bytes?]
[seconds number?]
[mime bytes?]
[headers (listof header?)])]{
@ -170,7 +170,7 @@ Here is an example typical of what you will find in many applications:
Example:
@schemeblock[
(make-response/basic
301 "Moved Permanently"
301 #"Moved Permanently"
(current-seconds) TEXT/HTML-MIME-TYPE
(list (make-header #"Location"
#"http://www.plt-scheme.org/downloads")))
@ -178,14 +178,14 @@ Here is an example typical of what you will find in many applications:
}
@defstruct[(response/full response/basic)
([body (listof (or/c string? bytes?))])]{
([body (listof bytes?)])]{
As with @scheme[response/basic], except with @scheme[body] as the response
body.
Example:
@schemeblock[
(make-response/full
301 "Moved Permanently"
301 #"Moved Permanently"
(current-seconds) TEXT/HTML-MIME-TYPE
(list (make-header #"Location"
#"http://www.plt-scheme.org/downloads"))
@ -198,7 +198,7 @@ Here is an example typical of what you will find in many applications:
}
@defstruct[(response/incremental response/basic)
([generator ((() (listof (or/c bytes? string?)) . ->* . any) . -> . any)])]{
([generator ((() (listof bytes?) . ->* . any) . -> . any)])]{
As with @scheme[response/basic], except with @scheme[generator] as a function that is
called to generate the response body, by being given an @scheme[output-response] function
that outputs the content it is called with.
@ -206,7 +206,7 @@ Here is an example typical of what you will find in many applications:
Here is a short example:
@schemeblock[
(make-response/incremental
200 "OK" (current-seconds)
200 #"OK" (current-seconds)
#"application/octet-stream"
(list (make-header #"Content-Disposition"
#"attachement; filename=\"file\""))
@ -214,16 +214,21 @@ Here is an example typical of what you will find in many applications:
(send/bytes #"Some content")
(send/bytes)
(send/bytes #"Even" #"more" #"content!")
(send/bytes "Now we're done")))
(send/bytes #"Now we're done")))
]
}
@defthing[response/c contract?]{
Equivalent to @scheme[(or/c response/basic?
(listof (or/c string? bytes?))
(cons/c bytes? (listof (or/c string? bytes?)))
xexpr/c)].
}
@defproc[(normalize-response [close? boolean?] [response response/c])
(or/c response/full? response/incremental?)]{
Coerces @scheme[response] into a full response, filling in additional details where appropriate.
}
@defthing[TEXT/HTML-MIME-TYPE bytes?]{Equivalent to @scheme[#"text/html; charset=utf-8"].}
@warning{If you include a Content-Length header in a response that is inaccurate, there @bold{will be an error} in

4
collects/web-server/scribblings/private.scrbl
View File

@ -464,6 +464,10 @@ needs. They are provided by @filepath{private/util.ss}.
@subsection{Bytes}
@defproc[(bytes-ci=? [b1 bytes?] [b2 bytes?]) boolean?]{
Compares two bytes case insensitively.
}
@defproc[(read/bytes [b bytes?])
serializable?]{
@scheme[read]s a value from @scheme[b] and returns it.