diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index f6cc7090ce..9674921a80 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -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"]) diff --git a/collects/tests/web-server/dispatchers/dispatch-files-test.ss b/collects/tests/web-server/dispatchers/dispatch-files-test.ss index 4083255a36..35b481cbba 100644 --- a/collects/tests/web-server/dispatchers/dispatch-files-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-files-test.ss @@ -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\nA titleHere's some content!") (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\nA titleHere's some content!") (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>A titleHere's some content!") (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\nA titleHere's some content!") (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)))))) diff --git a/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss b/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss index e6f633940e..4af308d8ff 100644 --- a/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss @@ -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")) diff --git a/collects/tests/web-server/private/response-test.ss b/collects/tests/web-server/private/response-test.ss index 89b09e6892..a2575c32e0 100644 --- a/collects/tests/web-server/private/response-test.ss +++ b/collects/tests/web-server/private/response-test.ss @@ -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\nHey!Content")) - ) - (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\nA titleHere's some content!") (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\nA titleHere's some content!") (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\nA titleHere's some content!") (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") (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>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") )))) diff --git a/collects/tests/web-server/servlet/bindings-test.ss b/collects/tests/web-server/servlet/bindings-test.ss index d3a35ac35d..26f61926da 100644 --- a/collects/tests/web-server/servlet/bindings-test.ss +++ b/collects/tests/web-server/servlet/bindings-test.ss @@ -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"))))) diff --git a/collects/tests/web-server/servlet/helpers-test.ss b/collects/tests/web-server/servlet/helpers-test.ss index 0d8f67c00d..f345d23e9c 100644 --- a/collects/tests/web-server/servlet/helpers-test.ss +++ b/collects/tests/web-server/servlet/helpers-test.ss @@ -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"))) diff --git a/collects/tests/web-server/util.ss b/collects/tests/web-server/util.ss index 50627b8e99..007be21461 100644 --- a/collects/tests/web-server/util.ss +++ b/collects/tests/web-server/util.ss @@ -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) diff --git a/collects/web-server/dispatchers/dispatch-log.ss b/collects/web-server/dispatchers/dispatch-log.ss index 8bb8689789..1f3b7d0187 100644 --- a/collects/web-server/dispatchers/dispatch-log.ss +++ b/collects/web-server/dispatchers/dispatch-log.ss @@ -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)) diff --git a/collects/web-server/formlets/date.ss b/collects/web-server/formlets/date.ss index ac7b4aeabf..a49ee78468 100644 --- a/collects/web-server/formlets/date.ss +++ b/collects/web-server/formlets/date.ss @@ -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") diff --git a/collects/web-server/http/redirect.ss b/collects/web-server/http/redirect.ss index 2fede44cda..0d2a96795a 100644 --- a/collects/web-server/http/redirect.ss +++ b/collects/web-server/http/redirect.ss @@ -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 diff --git a/collects/web-server/http/request-structs.ss b/collects/web-server/http/request-structs.ss index d00e3f44c6..e7dfb060ce 100644 --- a/collects/web-server/http/request-structs.ss +++ b/collects/web-server/http/request-structs.ss @@ -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?)] diff --git a/collects/web-server/http/request.ss b/collects/web-server/http/request.ss index bbfae455fd..58c3bf7c59 100644 --- a/collects/web-server/http/request.ss +++ b/collects/web-server/http/request.ss @@ -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)) diff --git a/collects/web-server/http/response-structs.ss b/collects/web-server/http/response-structs.ss index 7e63cfea2b..94a6181d48 100644 --- a/collects/web-server/http/response-structs.ss +++ b/collects/web-server/http/response-structs.ss @@ -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?]) diff --git a/collects/web-server/http/response.ss b/collects/web-server/http/response.ss index 8cba77ad44..786a0c3ec9 100644 --- a/collects/web-server/http/response.ss +++ b/collects/web-server/http/response.ss @@ -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)) diff --git a/collects/web-server/private/util.ss b/collects/web-server/private/util.ss index 1da37184dd..c814e1e79f 100644 --- a/collects/web-server/private/util.ss +++ b/collects/web-server/private/util.ss @@ -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))) diff --git a/collects/web-server/scribblings/http.scrbl b/collects/web-server/scribblings/http.scrbl index a2877bd46b..9ace7f9c2d 100644 --- a/collects/web-server/scribblings/http.scrbl +++ b/collects/web-server/scribblings/http.scrbl @@ -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 diff --git a/collects/web-server/scribblings/private.scrbl b/collects/web-server/scribblings/private.scrbl index 24707b68b7..a5089925c0 100644 --- a/collects/web-server/scribblings/private.scrbl +++ b/collects/web-server/scribblings/private.scrbl @@ -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.