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))] [html? (regexp-match? #rx"[.]html?$" (string-foldcase tag))]
[wxme? (regexp-match? [wxme? (regexp-match?
#rx#"^(?:#reader[(]lib\"read.ss\"\"wxme\"[)])?WXME" data)]) #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"] (cond [html? #"text/html"]
[wxme? #"application/data"] [wxme? #"application/data"]
[else #"text/plain"]) [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))) (list (cons 1 10) (cons 20 #f) (cons #f 30)))
(test-equal? "file, exists, whole, no Range, get" (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>") #"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" (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") #"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" (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>") #"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" (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") #"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" (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") #"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" (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") #"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" (test-exn "path, non"
exn:dispatcher? 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" (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>") #"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" (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") #"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" (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>") #"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" (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") #"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" (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") #"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" (test-exn "dir, not exists, get"
exn:dispatcher? 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" (test-exn "dir, not exists, head"
exn:dispatcher? 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 #:authentication-responder
(lambda (u h) (esc h)))) (lambda (u h) (esc h))))
(define-values (c i o) (make-mock-connection #"")) (define-values (c i o) (make-mock-connection #""))
(d c (make-request 'get (d c (make-request #"GET"
(if applies? (if applies?
(string->url "http://host/secret/something") (string->url "http://host/secret/something")
(string->url "http://host/not-secret")) (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) (apply f c any)
(redact (get-output-bytes o))) (redact (get-output-bytes o)))
(define response-tests (define output-response-tests
(test-suite (test-suite
"HTTP Responses"
(test-suite
"output-response" "output-response"
(test-suite (test-suite
"response/basic" "response/basic"
(test-equal? "response/basic" (test-equal? "response/basic"
(output output-response (output output-response
(make-response/basic 404 "404" (current-seconds) #"text/html" (make-response/basic 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") #"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)" (test-equal? "response/basic (header)"
(output output-response (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")))) (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") #"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)" (test-equal? "response/basic (body)"
(output output-response (output output-response
(make-response/basic 404 "404" (current-seconds) #"text/html" (make-response/basic 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") #"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)" (test-equal? "response/basic (bytes body)"
(output output-response (output output-response
(make-response/basic 404 "404" (current-seconds) #"text/html" (make-response/basic 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") #"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)" (test-equal? "response/basic (both)"
(output output-response (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")))) (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")) #"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" "response/full"
(test-equal? "response/full" (test-equal? "response/full"
(output output-response (output output-response
(make-response/full 404 "404" (current-seconds) #"text/html" (make-response/full 404 #"404" (current-seconds) #"text/html"
(list) (list))) (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") #"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)" (test-equal? "response/full (header)"
(output output-response (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))) (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") #"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)" (test-equal? "response/full (bytes body)"
(output output-response (output output-response
(make-response/full 404 "404" (current-seconds) #"text/html" (make-response/full 404 #"404" (current-seconds) #"text/html"
(list) (list #"Content!"))) (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!") #"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)" (test-equal? "response/full (both)"
(output output-response (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 "Content!"))) (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!")) #"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 (test-suite
"response/incremental" "response/incremental"
(test-equal? "response/incremental" (test-equal? "response/incremental"
(output output-response (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)))) (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") #"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)" (test-equal? "response/incremental (header)"
(output output-response (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")) (list (make-header #"Header" #"Value"))
(lambda (write) (void)))) (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") #"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)" (test-equal? "response/incremental (body)"
(output output-response (output output-response
(make-response/incremental 404 "404" (current-seconds) #"text/html" (make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list) (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") #"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)" (test-equal? "response/incremental (bytes body)"
(output output-response (output output-response
(make-response/incremental 404 "404" (current-seconds) #"text/html" (make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list) (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") #"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)" (test-equal? "response/incremental (both)"
(output output-response (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")) (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") #"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)" (test-equal? "response/incremental (twice)"
(output output-response (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")) (list (make-header #"Header" #"Value"))
(lambda (write) (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")) #"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 (test-suite
@ -145,87 +138,89 @@
(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: 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>")) #"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" "output-response/method"
(test-suite (test-suite
"response/full" "response/full"
(test-equal? "response/full" (test-equal? "response/full"
(output output-response/method (output output-response/method
(make-response/full 404 "404" (current-seconds) #"text/html" (make-response/full 404 #"404" (current-seconds) #"text/html"
(list) (list)) (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") #"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)" (test-equal? "response/full (header)"
(output output-response/method (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)) (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") #"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)" (test-equal? "response/full (body)"
(output output-response/method (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!")) (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") #"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)" (test-equal? "response/full (bytes body)"
(output output-response/method (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!")) (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") #"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)" (test-equal? "response/full (both)"
(output output-response/method (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 "Content!")) (list (make-header #"Header" #"Value")) (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\nHeader: Value\r\n\r\n")) #"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 (test-suite
"response/incremental" "response/incremental"
(test-equal? "response/incremental" (test-equal? "response/incremental"
(output output-response/method (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))) (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") #"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)" (test-equal? "response/incremental (header)"
(output output-response/method (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")) (list (make-header #"Header" #"Value"))
(lambda (write) (void))) (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") #"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)" (test-equal? "response/incremental (body)"
(output output-response/method (output output-response/method
(make-response/incremental 404 "404" (current-seconds) #"text/html" (make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list) (list)
(lambda (write) (write "Content!"))) (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") #"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)" (test-equal? "response/incremental (bytes body)"
(output output-response/method (output output-response/method
(make-response/incremental 404 "404" (current-seconds) #"text/html" (make-response/incremental 404 #"404" (current-seconds) #"text/html"
(list) (list)
(lambda (write) (write #"Content!"))) (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") #"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)" (test-equal? "response/incremental (both)"
(output output-response/method (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")) (list (make-header #"Header" #"Value"))
(lambda (write) (write "Content!"))) (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\nHeader: Value\r\n\r\n") #"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)" (test-equal? "response/incremental (twice)"
(output output-response/method (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")) (list (make-header #"Header" #"Value"))
(lambda (write) (lambda (write)
(write "Content!") (write #"Content!")
(write "Content!"))) (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\nHeader: Value\r\n\r\n")) #"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 (test-suite
@ -233,17 +228,17 @@
(test-equal? "empty" (test-equal? "empty"
(output output-response/method (output output-response/method
(list #"text/html") (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") #"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" (test-equal? "not"
(output output-response/method (output output-response/method
(list #"text/html" "Content") (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") #"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" (test-equal? "not, bytes"
(output output-response/method (output output-response/method
(list #"text/html" #"Content") (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")) #"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 (test-suite
@ -251,8 +246,17 @@
(test-equal? "any" (test-equal? "any"
(output output-response/method (output output-response/method
`(html (head (title "Hey!")) (body "Content")) `(html (head (title "Hey!")) (body "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; charset=utf-8\r\nContent-Length: 65\r\n\r\n"))) #"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 () (let ()
(define tmp-file (make-temporary-file)) (define tmp-file (make-temporary-file))
(with-output-to-file tmp-file (with-output-to-file tmp-file
@ -274,75 +278,75 @@
"output-file" "output-file"
(test-equal? "(get) whole file - no Range header" (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>") #"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" (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>") #"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" (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>") #"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" (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") #"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" (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>") #"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" (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>") #"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" (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") #"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" (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") #"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" (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") #"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" (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") #"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" (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") #"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" (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") #"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" (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") #"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" (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") #"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" (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") #"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" (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") #"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" (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") #"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" (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") #"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 (test-case
"Simple" "Simple"
(check-equal? (request-bindings (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 empty (list (make-binding:form #"key" #"val")) #f
"host" 80 "client")) "host" 80 "client"))
'((key . "val")))) '((key . "val"))))
(test-case (test-case
"Case" "Case"
(check-equal? (request-bindings (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 empty (list (make-binding:form #"KEY" #"val")) #f
"host" 80 "client")) "host" 80 "client"))
'((key . "val")))) '((key . "val"))))
(test-case (test-case
"Multi" "Multi"
(check-equal? (request-bindings (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") empty (list (make-binding:form #"key" #"val")
(make-binding:form #"key2" #"val")) #f (make-binding:form #"key2" #"val")) #f
"host" 80 "client")) "host" 80 "client"))
@ -40,7 +40,7 @@
(test-case (test-case
"File" "File"
(check-equal? (request-bindings (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 empty (list (make-binding:file #"key" #"file" empty #"val")) #f
"host" 80 "client")) "host" 80 "client"))
'((key . #"val"))))) '((key . #"val")))))
@ -50,14 +50,14 @@
(test-case (test-case
"Simple" "Simple"
(check-equal? (request-headers (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 (list (make-header #"key" #"val")) empty #f
"host" 80 "client")) "host" 80 "client"))
'((key . "val")))) '((key . "val"))))
(test-case (test-case
"Case" "Case"
(check-equal? (request-headers (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 (list (make-header #"KEY" #"val")) empty #f
"host" 80 "client")) "host" 80 "client"))
'((key . "val"))))) '((key . "val")))))

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

@ -29,13 +29,13 @@
302) 302)
(test-equal? "Message (temp)" (test-equal? "Message (temp)"
(response/basic-message (redirect-to "http://test.com/foo")) (response/basic-message (redirect-to "http://test.com/foo"))
"Moved Temporarily") #"Moved Temporarily")
(test-equal? "Code" (test-equal? "Code"
(response/basic-code (redirect-to "http://test.com/foo" permanently)) (response/basic-code (redirect-to "http://test.com/foo" permanently))
301) 301)
(test-equal? "Message" (test-equal? "Message"
(response/basic-message (redirect-to "http://test.com/foo" permanently)) (response/basic-message (redirect-to "http://test.com/foo" permanently))
"Moved Permanently") #"Moved Permanently")
(test-equal? "URL" (test-equal? "URL"
(dehead (response/basic-headers (redirect-to "http://test.com/foo"))) (dehead (response/basic-headers (redirect-to "http://test.com/foo")))
(list (list #"Location" #"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) call)
(define (call d u bs) (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) (define (htxml bs)
(match (regexp-match #"^.+\r\n\r\n(.+)$" bs) (match (regexp-match #"^.+\r\n\r\n(.+)$" bs)
[(list _ s) [(list _ s)

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

@ -42,7 +42,7 @@
(define (request-line-raw req) (define (request-line-raw req)
(format "~a ~a HTTP/1.1" (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)))) (url->string (request-uri req))))
(define (apache-default-format req) (define (apache-default-format req)
(define request-time (srfi-date:current-date)) (define request-time (srfi-date:current-date))

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

@ -45,7 +45,7 @@
(require net/url (require net/url
web-server/servlet) web-server/servlet)
(formlet-process travel-formlet (formlet-process travel-formlet
(make-request 'get (string->url "http://test.com") (make-request #"GET" (string->url "http://test.com")
empty empty
(list (make-binding:form #"input_0" #"Jay") (list (make-binding:form #"input_0" #"Jay")
(make-binding:form #"input_1" #"10") (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 (require web-server/http/response-structs
web-server/http/request-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-struct redirection-status (code message))
(define permanently (make-redirection-status 301 "Moved Permanently")) (define permanently (make-redirection-status 301 #"Moved Permanently"))
(define temporarily (make-redirection-status 302 "Moved Temporarily")) (define temporarily (make-redirection-status 302 #"Moved Temporarily"))
(define see-other (make-redirection-status 303 "See Other")) (define see-other (make-redirection-status 303 #"See Other"))
; : str [redirection-status] -> response ; : str [redirection-status] -> response
(define(redirect-to (define(redirect-to

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

@ -2,11 +2,8 @@
(require mzlib/contract (require mzlib/contract
mzlib/serialize mzlib/serialize
mzlib/plt-match mzlib/plt-match
net/url) net/url
web-server/private/util)
(define (bytes-ci=? b0 b1)
(string-ci=? (bytes->string/utf-8 b0)
(bytes->string/utf-8 b1)))
(define-serializable-struct header (field value)) (define-serializable-struct header (field value))
(define (headers-assq* f hs) (define (headers-assq* f hs)
@ -52,10 +49,9 @@
[headers (listof header?)] [headers (listof header?)]
[content bytes?])]) [content bytes?])])
(define-serializable-struct request (method uri headers/raw bindings/raw post-data/raw (define-serializable-struct request (method uri headers/raw bindings/raw post-data/raw host-ip host-port client-ip))
host-ip host-port client-ip))
(provide/contract (provide/contract
[struct request ([method symbol?] [struct request ([method bytes?]
[uri url?] [uri url?]
[headers/raw (listof header?)] [headers/raw (listof header?)]
[bindings/raw (listof binding?)] [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]+)$")]) (let ([rx (byte-regexp #"^([^ ]+) (.+) HTTP/([0-9]+)\\.([0-9]+)$")])
(lambda (a) (regexp-match rx a)))) (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" ; 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 ; effect: in case of errors, complain [MF: where] and close the ports
(define (read-request-line ip) (define (read-request-line ip)
@ -98,7 +98,7 @@
[(match-method line) [(match-method line)
=> (match-lambda => (match-lambda
[(list _ method url major minor) [(list _ method url major minor)
(values (lowercase-symbol! (bytes->string/utf-8 method)) (values method
(string->url (bytes->string/utf-8 url)) (string->url (bytes->string/utf-8 url))
(string->number (bytes->string/utf-8 major)) (string->number (bytes->string/utf-8 major))
(string->number (bytes->string/utf-8 minor)))])] (string->number (bytes->string/utf-8 minor)))])]
@ -110,7 +110,7 @@
(let ([rx (byte-regexp (bytes-append #"^([^:]*):[ " (bytes 9) #"]*(.*)"))]) (let ([rx (byte-regexp (bytes-append #"^([^:]*):[ " (bytes 9) #"]*(.*)"))])
(lambda (a) (regexp-match rx a)))) (lambda (a) (regexp-match rx a))))
; read-headers : iport -> (listof (cons symbol bytes)) ; read-headers : iport -> (listof header?)
(define (read-headers in) (define (read-headers in)
(let read-header () (let read-header ()
(define l (read-bytes-line in 'any)) (define l (read-bytes-line in 'any))

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

@ -1,5 +1,6 @@
#lang scheme/base #lang scheme/base
(require mzlib/contract (require mzlib/contract
scheme/list
xml/xml xml/xml
web-server/http/request-structs) web-server/http/request-structs)
@ -9,35 +10,90 @@
(define-struct (response/full response/basic) (body)) (define-struct (response/full response/basic) (body))
(define-struct (response/incremental response/basic) (generator)) (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 (define response/c
(or/c response/basic? (or/c response/basic?
(listof (or/c string? bytes?)) (cons/c bytes? (listof (or/c string? bytes?)))
xexpr/c)) 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 (provide/contract
[struct response/basic [struct response/basic
([code number?] ([code number?]
[message string?] [message bytes?]
[seconds number?] [seconds number?]
[mime bytes?] [mime bytes?]
[headers (listof header?)])] [headers (listof header?)])]
[struct (response/full response/basic) [struct (response/full response/basic)
([code number?] ([code number?]
[message string?] [message bytes?]
[seconds number?] [seconds number?]
[mime bytes?] [mime bytes?]
[headers (listof header?)] [headers (listof header?)]
[body (listof (or/c string? [body (listof bytes?)])]
bytes?))])]
[struct (response/incremental response/basic) [struct (response/incremental response/basic)
([code number?] ([code number?]
[message string?] [message bytes?]
[seconds number?] [seconds number?]
[mime bytes?] [mime bytes?]
[headers (listof header?)] [headers (listof header?)]
[generator ((() (listof (or/c bytes? string?)) . ->* . any) . -> . any)])] [generator ((() (listof bytes?) . ->* . any) . -> . any)])]
[response/c contract?] [response/c contract?]
[normalize-response (boolean? response/c . -> . (or/c response/full? response/incremental?))]
[TEXT/HTML-MIME-TYPE bytes?]) [TEXT/HTML-MIME-TYPE bytes?])

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

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

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

@ -26,7 +26,12 @@
[read/string (string? . -> . serializable?)] [read/string (string? . -> . serializable?)]
[write/string (serializable? . -> . string?)] [write/string (serializable? . -> . string?)]
[read/bytes (bytes? . -> . serializable?)] [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) (define (read/string str)
(read (open-input-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]. 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?] [uri url?]
[headers/raw (listof header?)] [headers/raw (listof header?)]
[bindings/raw (listof binding?)] [bindings/raw (listof binding?)]
@ -158,7 +158,7 @@ Here is an example typical of what you will find in many applications:
@defstruct[response/basic @defstruct[response/basic
([code number?] ([code number?]
[message string?] [message bytes?]
[seconds number?] [seconds number?]
[mime bytes?] [mime bytes?]
[headers (listof header?)])]{ [headers (listof header?)])]{
@ -170,7 +170,7 @@ Here is an example typical of what you will find in many applications:
Example: Example:
@schemeblock[ @schemeblock[
(make-response/basic (make-response/basic
301 "Moved Permanently" 301 #"Moved Permanently"
(current-seconds) TEXT/HTML-MIME-TYPE (current-seconds) TEXT/HTML-MIME-TYPE
(list (make-header #"Location" (list (make-header #"Location"
#"http://www.plt-scheme.org/downloads"))) #"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) @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 As with @scheme[response/basic], except with @scheme[body] as the response
body. body.
Example: Example:
@schemeblock[ @schemeblock[
(make-response/full (make-response/full
301 "Moved Permanently" 301 #"Moved Permanently"
(current-seconds) TEXT/HTML-MIME-TYPE (current-seconds) TEXT/HTML-MIME-TYPE
(list (make-header #"Location" (list (make-header #"Location"
#"http://www.plt-scheme.org/downloads")) #"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) @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 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 called to generate the response body, by being given an @scheme[output-response] function
that outputs the content it is called with. 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: Here is a short example:
@schemeblock[ @schemeblock[
(make-response/incremental (make-response/incremental
200 "OK" (current-seconds) 200 #"OK" (current-seconds)
#"application/octet-stream" #"application/octet-stream"
(list (make-header #"Content-Disposition" (list (make-header #"Content-Disposition"
#"attachement; filename=\"file\"")) #"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 #"Some content")
(send/bytes) (send/bytes)
(send/bytes #"Even" #"more" #"content!") (send/bytes #"Even" #"more" #"content!")
(send/bytes "Now we're done"))) (send/bytes #"Now we're done")))
] ]
} }
@defthing[response/c contract?]{ @defthing[response/c contract?]{
Equivalent to @scheme[(or/c response/basic? Equivalent to @scheme[(or/c response/basic?
(listof (or/c string? bytes?)) (cons/c bytes? (listof (or/c string? bytes?)))
xexpr/c)]. 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"].} @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 @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} @subsection{Bytes}
@defproc[(bytes-ci=? [b1 bytes?] [b2 bytes?]) boolean?]{
Compares two bytes case insensitively.
}
@defproc[(read/bytes [b bytes?]) @defproc[(read/bytes [b bytes?])
serializable?]{ serializable?]{
@scheme[read]s a value from @scheme[b] and returns it. @scheme[read]s a value from @scheme[b] and returns it.