diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss
index aabbd2e5ba..826b3af0fb 100644
--- a/collects/web-server/dispatchers/dispatch-files.ss
+++ b/collects/web-server/dispatchers/dispatch-files.ss
@@ -1,16 +1,22 @@
(module dispatch-files mzscheme
+
(require (lib "url.ss" "net")
(lib "kw.ss")
(lib "plt-match.ss")
+ (lib "pregexp.ss")
(lib "contract.ss"))
+
(require "dispatch.ss"
"../private/util.ss"
"../private/request-structs.ss"
"../private/response-structs.ss"
"../servlet/helpers.ss"
"../private/response.ss")
+
(provide/contract
- [interface-version dispatcher-interface-version?])
+ [interface-version dispatcher-interface-version?]
+ [read-range-header (-> (listof header?) (or/c (listof pair?) false/c))])
+
(provide make)
;; looks-like-directory : str -> bool
@@ -19,6 +25,7 @@
(eq? #\/ (string-ref path (sub1 (string-length path)))))
(define interface-version 'v1)
+
(define/kw (make #:key
url->path
[path->mime-type (lambda (path) TEXT/HTML-MIME-TYPE)]
@@ -27,43 +34,68 @@
(define uri (request-uri req))
(define method (request-method req))
(define-values (path _) (url->path uri))
- (cond
- [(file-exists? path)
- (match (headers-assq* #"Range" (request-headers/raw req))
- [#f
- (output-file conn path method (path->mime-type path)
- 0 +inf.0)]
- [range
- (match (bytes->string/utf-8 (header-value range))
- [(regexp "^bytes=(.*)-(.*)$" (list s start end))
- (define startn
- (if (string=? "" start)
- 0
- (string->number start)))
- (define endn
- (if (string=? "" end)
- +inf.0
- (string->number end)))
- (output-file conn path method (path->mime-type path)
- startn endn)]
- [r
- (fprintf (current-error-port)
- "dispatch-files.ss: Received a range that was not parseable(~S). If you see this message, please file a PLT bug report."
- r)
- (output-file conn path method (path->mime-type path)
- 0 +inf.0)])])]
- [(directory-exists? path)
- (if (looks-like-directory? (url-path->string (url-path uri)))
- (let/ec esc
- (for-each (lambda (dir-default)
- (define full-name (build-path path dir-default))
- (when (file-exists? full-name)
- (esc (output-file conn full-name method (path->mime-type full-name)
- 0 +inf.0))))
- indices)
- (next-dispatcher))
- (output-response
- conn
- (redirect-to (string-append (url-path->string (url-path uri)) "/"))))]
- [else
- (next-dispatcher)]))))
\ No newline at end of file
+ (cond [(file-exists? path)
+ (output-file conn path method (path->mime-type path)
+ (read-range-header (request-headers/raw req)))]
+ [(directory-exists? path)
+ (if (looks-like-directory? (url-path->string (url-path uri)))
+ (let/ec esc
+ (for-each (lambda (dir-default)
+ (define full-name (build-path path dir-default))
+ (when (file-exists? full-name)
+ (esc (output-file conn full-name method (path->mime-type full-name)
+ (read-range-header (request-headers/raw req))))))
+ indices)
+ (next-dispatcher))
+ (output-response
+ conn
+ (redirect-to (string-append (url-path->string (url-path uri)) "/"))))]
+ [else (next-dispatcher)])))
+
+ ;; read-range-header : (listof header) -> (U (alist-of (U integer #f) (U integer #f)) #f)
+ ;;
+ ;; Returns a list of pairs of the byte offsets specified in an HTTP Range
+ ;; header, or #f if the header is missing or malformed.
+ ;;
+ ;; The HTTP spec for the Range header can be found here:
+ ;;
+ ;; http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.35
+ ;;
+ ;; More specifically, the (non-#f form of the) result is:
+ ;;
+ ;; (list-of (U byte-range-spec suffix-byte-range-spec))
+ ;;
+ ;; where:
+ ;;
+ ;; byte-range-spec : (cons integer (U integer #f))
+ ;; suffix-byte-range-spec : (cons #f integer)
+ ;;
+ ;; All offsets are inclusive: the integers are precisely those that appear
+ ;; in the header.
+ (define read-range-header
+ (let ([range-header-regexp #px#"^bytes=(.*)$"]
+ [range-delimiter-regexp #px#","]
+ [range-regexp #px#"^([0-9]*)-([0-9]*)$"]
+ [range-error (lambda (header)
+ (fprintf (current-error-port)
+ (format "Bad Range header: ~s. File a PLT bug report!~n"
+ (header-value header)))
+ #f)])
+ (lambda (headers)
+ (let ([header (headers-assq* #"Range" headers)])
+ (if header
+ (let/ec escape
+ (match (pregexp-match range-header-regexp (header-value header))
+ [(list _ ranges-string)
+ (let ([ranges (pregexp-split range-delimiter-regexp ranges-string)])
+ (map (lambda (range-string)
+ (match (pregexp-match range-regexp range-string)
+ [(list _ start-offset end-offset)
+ (cons (string->number (bytes->string/utf-8 start-offset))
+ (string->number (bytes->string/utf-8 end-offset)))]
+ [#f (escape (range-error header))]))
+ ranges))]
+ [#f (escape (range-error header))]))
+ #f)))))
+
+ )
\ No newline at end of file
diff --git a/collects/web-server/private/response.ss b/collects/web-server/private/response.ss
index 002b8fe7c9..fc2fd10f60 100644
--- a/collects/web-server/private/response.ss
+++ b/collects/web-server/private/response.ss
@@ -1,8 +1,11 @@
(module response mzscheme
(require (lib "contract.ss")
+ (lib "md5.ss")
(lib "port.ss")
(lib "list.ss")
(lib "plt-match.ss")
+ (only (lib "list.ss" "srfi" "1") fold filter-map)
+ (only (lib "string.ss" "srfi" "13") string-join)
(lib "xml.ss" "xml")
"connection-manager.ss"
"../private/request-structs.ss"
@@ -12,7 +15,7 @@
(provide/contract
[rename ext:output-response output-response (connection? response? . -> . void)]
[rename ext:output-response/method output-response/method (connection? response? symbol? . -> . void)]
- [rename ext:output-file output-file (connection? path? symbol? bytes? integer? integer? . -> . void)])
+ [rename ext:output-file output-file (connection? path? symbol? bytes? (or/c pair? false/c) . -> . void)])
;; Table 1. head responses:
; ------------------------------------------------------------------------------
@@ -100,20 +103,32 @@
;; NOTE: According to RFC 2145 the server should write HTTP/1.1
;; header for *all* clients.
(define (output-headers+response/basic conn bresp)
- (define o-port (connection-o-port conn))
- (fprintf o-port "HTTP/1.1 ~a ~a\r\n" (response/basic-code bresp) (response/basic-message bresp))
+ (fprintf (connection-o-port conn)
+ "HTTP/1.1 ~a ~a\r\n"
+ (response/basic-code bresp)
+ (response/basic-message bresp))
+ (output-headers
+ conn
+ (list* (make-header #"Date" (string->bytes/utf-8 (seconds->gmt-string (current-seconds))))
+ (make-header #"Last-Modified" (string->bytes/utf-8 (seconds->gmt-string (response/basic-seconds bresp))))
+ (make-header #"Server" #"PLT Scheme")
+ (make-header #"Content-Type" (response/basic-mime bresp))
+ (append (if (connection-close? conn)
+ (list (make-header #"Connection" #"close"))
+ empty)
+ (response/basic-headers bresp)))))
+
+ ;; output-headers : connection (list-of header) -> void
+ (define (output-headers conn headers)
+ (print-headers (connection-o-port conn) headers))
+
+ ;; print-headers : output-port (list-of header) -> void
+ (define (print-headers out headers)
(for-each (match-lambda
[(struct header (field value))
- (fprintf o-port "~a: ~a\r\n" field value)])
- (list* (make-header #"Date" (string->bytes/utf-8 (seconds->gmt-string (current-seconds))))
- (make-header #"Last-Modified" (string->bytes/utf-8 (seconds->gmt-string (response/basic-seconds bresp))))
- (make-header #"Server" #"PLT Scheme")
- (make-header #"Content-Type" (response/basic-mime bresp))
- (append (if (connection-close? conn)
- (list (make-header #"Connection" #"close"))
- empty)
- (response/basic-headers bresp))))
- (fprintf o-port "\r\n"))
+ (fprintf out "~a: ~a\r\n" field value)])
+ headers)
+ (fprintf out "\r\n"))
(define (output-response/basic conn bresp)
(define o-port (connection-o-port conn))
@@ -184,33 +199,252 @@
(define (response/full->size resp)
(apply + (map data-length (response/full-body resp))))
- ;; output-file: connection path symbol bytes integer integer -> void
- (define (output-file conn file-path method mime-type
- start end-or-inf)
- (define total-len (file-size file-path))
- (define end (if (equal? +inf.0 end-or-inf)
- total-len
- end-or-inf))
- (define len (- end start))
- (define bresp
- (make-response/basic 206 "Okay" (file-or-directory-modify-seconds file-path) mime-type
- (list (make-header #"Content-Length" (string->bytes/utf-8 (number->string len)))
- ; XXX Remove on non-gets?
- (make-header #"Content-Range" (string->bytes/utf-8 (format "bytes ~a-~a/~a" start end total-len))))))
- (output-headers+response/basic conn bresp)
- (when (eq? method 'get)
- ; XXX Move out?
- (adjust-connection-timeout! conn len) ; Give it one second per byte.
- (with-handlers ([void (lambda (e) (network-error 'output-file/partial (exn-message e)))])
- (call-with-input-file file-path
- (lambda (i-port)
- (define _ (file-position i-port start))
- (define i-port/end (make-limited-input-port i-port end #t))
- (copy-port i-port/end (connection-o-port conn))
- (close-input-port i-port/end))))))
+ ;; output-file: connection
+ ;; path
+ ;; symbol
+ ;; bytes
+ ;; (U (listof (U byte-range-spec suffix-byte-range-spec)) #f)
+ ;; -> void
+ ;;
+ ;; Ranges is #f if the client did not specify a Range header, or:
+ ;;
+ ;; (list-of (U byte-range-spec suffix-byte-range-spec))
+ ;;
+ ;; where:
+ ;;
+ ;; byte-range-spec : (cons integer (U integer #f))
+ ;; suffix-byte-range-spec : (cons #f integer)
+ ;;
+ ;; as described in the comments in dispatchers/dispatch-files.ss.
+ ;;
+ ;; A boundary is generated only if a multipart/byteranges response needs
+ ;; to be generated (i.e. if a Ranges header was specified with more than
+ ;; one range in it).
+ (define (output-file conn file-path method mime-type ranges)
+ (output-file/boundary
+ conn
+ file-path
+ method
+ mime-type
+ ranges
+ (if (and ranges (> (length ranges) 1))
+ (md5 (string->bytes/utf-8 (number->string (current-inexact-milliseconds))))
+ #f)))
+
+ ;; output-file: connection
+ ;; path
+ ;; symbol
+ ;; bytes
+ ;; (U (listof (U byte-range-spec suffix-byte-range-spec)) #f)
+ ;; (U bytes #f)
+ ;; -> void
+ (define (output-file/boundary conn file-path method mime-type ranges boundary)
+ ; total-file-length : integer
+ (define total-file-length
+ (file-size file-path))
+ ; modified-seconds : integer
+ (define modified-seconds
+ (file-or-directory-modify-seconds file-path))
+ ; boundary-length : (U integer #f)
+ (define boundary-length
+ (if boundary
+ (bytes-length boundary)
+ #f))
+ ; If convert-http-ranges fails, send a 416 bad range resposne:
+ (with-handlers ([exn:fail?
+ (lambda (exn)
+ (fprintf (current-error-port)
+ (format "~a File a PLT bug report if this is on a live server!~n" (exn-message exn)))
+ (output-headers+response/basic
+ conn
+ (make-416-response modified-seconds mime-type)))])
+ (let* (; converted-ranges : (alist-of integer integer)
+ ; This is a list of actual start and end offsets in the file.
+ ; See the comments for convert-http-ranges for more information.
+ [converted-ranges
+ (if ranges
+ (convert-http-ranges ranges total-file-length)
+ (list (cons 0 total-file-length)))]
+ ; multipart-headers : (list-of bytes)
+ ; This is a list of header blocks to prepend to each range being sent.
+ ; The idea is so we can calculate an overall content-length for the
+ ; response. This *must be* the same length as converted-ranges.
+ [multipart-headers
+ (if (> (length converted-ranges) 1)
+ (prerender-multipart/byteranges-headers mime-type converted-ranges total-file-length)
+ (list #""))]
+ ; total-content-length : integer
+ [total-content-length
+ (if (= (length converted-ranges) 1)
+ ; One range: content-length is the length of the range being sent:
+ (- (cdar converted-ranges) (caar converted-ranges))
+ ; Multiple ranges: content-length is the length of the multipart,
+ ; including content, headers and boundaries:
+ (fold (lambda (range headers accum)
+ (+ accum ; length so far
+ (bytes-length headers) ; length of the headers and header newlinw
+ (- (cdr range) (car range)) ; length of the content
+ 2)) ; length of the content newline
+ (+ (* (+ boundary-length 4)
+ (length converted-ranges)) ; length of the intermediate boundaries
+ (+ boundary-length 6)) ; length of the final boundary
+ converted-ranges
+ multipart-headers))])
+ ; Send a 206 iff ranges were specified in the request:
+ (output-headers+response/basic
+ conn
+ (if ranges
+ (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)
+ ; XXX Move out?
+ (adjust-connection-timeout! ; Give it one second per byte.
+ conn
+ (apply + (map (lambda (range)
+ (- (cdr range) (car range)))
+ converted-ranges)))
+ (with-handlers ([exn? (lambda (exn) (network-error 'output-file (exn-message exn)))])
+ (call-with-input-file file-path
+ (lambda (input)
+ (if (= (length converted-ranges) 1)
+ ; Single ranges (in 200 or 206 responses) are sent straight out
+ ; in their simplest form:
+ (output-file-range conn input (caar converted-ranges) (cdar converted-ranges))
+ ; Multiple ranges are encoded as multipart/byteranges:
+ (let loop ([ranges converted-ranges] [multipart-headers multipart-headers])
+ (match ranges
+ [(list)
+ ; Final boundary (must start on new line; ends with a new line)
+ (fprintf (connection-o-port conn) "--~a--\r\n" boundary)
+ (void)]
+ [(list-rest (list-rest start end) rest)
+ ; Intermediate boundary (must start on new line; ends with a new line)
+ (fprintf (connection-o-port conn) "--~a\r\n" boundary)
+ ; Headers and new line
+ (display (car multipart-headers) (connection-o-port conn))
+ ; Content
+ (output-file-range conn input start end)
+ ; Newline before next field
+ (fprintf (connection-o-port conn) "\r\n")
+ (loop rest (cdr multipart-headers))]))))))))))
+
+ ;; prerender-multipart/byteranges-headers : bytes (alist-of integer integer) integer -> (list-of bytes)
+ (define (prerender-multipart/byteranges-headers mime-type converted-ranges total-file-length)
+ (map (lambda (range)
+ (match range
+ [(list-rest start end)
+ (let ([out (open-output-bytes)])
+ (print-headers out (list (make-header #"Content-Type" mime-type)
+ (make-content-range-header start end total-file-length)))
+ (begin0 (get-output-bytes out)
+ (close-output-port out)))]))
+ converted-ranges))
+
+ ;; output-file-range : connection file-input-port integer integer -> void
+ ;;
+ ;; start must be inclusive; end must be exclusive.
+ (define (output-file-range conn input start end)
+ (file-position input start)
+ (let ([limited-input (make-limited-input-port input (- end start) #f)])
+ (copy-port limited-input (connection-o-port conn))
+ (close-input-port limited-input)))
+
+ ;; convert-http-ranges : (alist-of (U integer #f) (U integer #f))
+ ;; integer
+ ;; -> (alist-of integer integer)
+ ;;
+ ;; Converts a list of HTTP ranges:
+ ;;
+ ;; into pairs of offsets we can use to read from a file:
+ ;;
+ ;; - suffix-byte-range-specs are converted to pairs of absolute offsets;
+ ;; - missing end offsets in byte-range-specs ranges are filled in;
+ ;; - end offsets are exclusive (as opposed to the inclusive offsets in ranges and the HTTP spec).
+ ;;
+ ;; The HTTP spec recommends that ranges are sent in the order they are specified in the request.
+ (define (convert-http-ranges ranges total-file-length)
+ (define converted
+ (filter-map (lambda (range)
+ ; a : (U integer #f)
+ ; b : (U integer #f)
+ ; The original values quoted in the Range header:
+ (define-values (a b)
+ (values (car range)
+ (cdr range)))
+ ; a* : integer
+ ; b* : integer
+ ; Convert inclusive end offsets and suffix ranges:
+ (define-values (a* b*)
+ (cond [(not a) (values (- total-file-length b) total-file-length)]
+ [(not b) (values a total-file-length)]
+ [else (values a (add1 b))]))
+ ; a** : integer
+ ; b** : integer
+ ; Trim to the size of the file:
+ (define-values (a** b**)
+ (values (max 0 (min total-file-length a*))
+ (max 0 (min total-file-length b*))))
+ ; Get rid of zero-length ranges (including ones that are outside the file length):
+ (if (< a** b**)
+ (cons a** b**)
+ #f))
+ ranges))
+ (if (null? converted)
+ (error (format "No satisfiable ranges in ~a/~a." ranges total-file-length))
+ converted))
+
+ ;; make-206-response : integer bytes integer integer (alist-of integer integer) bytes -> basic-response
+ (define (make-206-response modified-seconds mime-type total-content-length total-file-length converted-ranges boundary)
+ (if (= (length converted-ranges) 1)
+ (let ([start (caar converted-ranges)]
+ [end (cdar converted-ranges)])
+ (make-response/basic
+ 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"
+ modified-seconds
+ (bytes-append #"multipart/byteranges; boundary=" boundary)
+ (list (make-header #"Accept-Ranges" #"bytes")
+ (make-content-length-header total-content-length)))))
+
+ ;; make-200-response : integer bytes integer -> basic-response
+ (define (make-200-response modified-seconds mime-type total-content-length)
+ (make-response/basic
+ 200 "OK"
+ modified-seconds
+ mime-type
+ (list (make-header #"Accept-Ranges" #"bytes")
+ (make-content-length-header total-content-length))))
+
+ ;; make-416-response : integer bytes -> basic-response
+ (define (make-416-response modified-seconds mime-type)
+ (make-response/basic
+ 416 "Invalid range request"
+ modified-seconds
+ mime-type
+ null))
+
+ ;; make-content-length-header : integer -> header
+ (define (make-content-length-header total-content-length)
+ (make-header #"Content-Length" (string->bytes/utf-8 (number->string total-content-length))))
+
+ ;; make-content-range-header : integer integer integer -> header
+ ;; start must be inclusive; end must be exclusive.
+ (define (make-content-range-header start end total-file-length)
+ (make-header #"Content-Range"
+ (string->bytes/utf-8
+ (format "bytes ~a-~a/~a" start (sub1 end) total-file-length))))
(define ext:output-file
- (ext:wrap output-file))
+ (ext:wrap output-file))
(define ext:output-response/method
- (ext:wrap output-response/method)))
\ No newline at end of file
+ (ext:wrap output-response/method))
+
+ )
\ No newline at end of file
diff --git a/collects/web-server/tests/dispatchers/dispatch-files-test.ss b/collects/web-server/tests/dispatchers/dispatch-files-test.ss
index 689baf3ecb..9a4006b04a 100644
--- a/collects/web-server/tests/dispatchers/dispatch-files-test.ss
+++ b/collects/web-server/tests/dispatchers/dispatch-files-test.ss
@@ -40,29 +40,60 @@
(test-suite
"Files"
- (test-equal? "file, exists, whole, get"
+ (test-case
+ "read-range-header: missing and badly formed headers"
+ (check-false (files:read-range-header (list (make-header #"Ranges" #"bytes=1-10"))) "check 1")
+ (check-false (files:read-range-header (list (make-header #"Range" #"completely wrong"))) "check 2")
+ (check-false (files:read-range-header (list (make-header #"Range" #"byte=1-10"))) "check 3")
+ (check-false (files:read-range-header (list (make-header #"Range" #"bytes=a-10"))) "check 4")
+ (check-false (files:read-range-header (list (make-header #"Range" #"bytes=1-1.0"))) "check 5"))
+
+ (test-case
+ "read-range-header: single range"
+ (check-equal? (files:read-range-header (list (make-header #"Range" #"bytes=1-10"))) (list (cons 1 10)) "check 1")
+ (check-equal? (files:read-range-header (list (make-header #"Range" #"bytes=1-"))) (list (cons 1 #f)) "check 2")
+ (check-equal? (files:read-range-header (list (make-header #"Range" #"bytes=-10"))) (list (cons #f 10)) "check 3"))
+
+ (test-equal?
+ "read-range-header: multiple ranges"
+ (files:read-range-header (list (make-header #"Range" #"bytes=1-10,20-,-30")))
+ (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))
- #"HTTP/1.1 206 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: 81\r\nContent-Range: bytes 0-81/81\r\n\r\nA titleHere's some content!")
- (test-equal? "file, exists, whole, head"
+ #"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))
- #"HTTP/1.1 206 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: 81\r\nContent-Range: bytes 0-81/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"
+ (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"))))
+ #"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-10"))))
- #"HTTP/1.1 206 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: 5\r\nContent-Range: bytes 5-10/81\r\n\r\n>A titleHere's some content!")
- (test-equal? "dir, exists, head"
+ #"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? "dir, exists, no Range, head"
(collect (dispatch #t a-dir) (req #t 'head empty))
- #"HTTP/1.1 206 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: 81\r\nContent-Range: bytes 0-81/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"
+ (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"))))
+ #"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))
#"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")
diff --git a/collects/web-server/tests/private/response-test.ss b/collects/web-server/tests/private/response-test.ss
index 42f035bcb9..661503250a 100644
--- a/collects/web-server/tests/private/response-test.ss
+++ b/collects/web-server/tests/private/response-test.ss
@@ -1,11 +1,19 @@
(module response-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+ (planet "util.ss" ("schematics" "schemeunit.plt" 2))
(lib "xml.ss" "xml")
(lib "file.ss")
(lib "response.ss" "web-server" "private")
(lib "request-structs.ss" "web-server" "private")
(lib "response-structs.ss" "web-server" "private")
"../util.ss")
+
+ (require/expose (lib "response.ss" "web-server" "private")
+ (convert-http-ranges
+ make-content-length-header
+ make-content-range-header
+ output-file/boundary))
+
(provide response-tests)
(define (output f . any)
@@ -19,6 +27,7 @@
(test-suite
"output-response"
+
(test-suite
"response/full"
(test-equal? "response/full"
@@ -217,37 +226,89 @@
`(html (head (title "A title"))
(body "Here's some content!")))))
'truncate/replace)
+
+ (test-equal?
+ "convert-http-ranges"
+ (convert-http-ranges
+ '((10 . #f) (20 . 30) (#f . 40) (40 . 60) (49 . 60))
+ 50)
+ '((10 . 50) (20 . 31) (10 . 50) (40 . 50)))
+
(test-suite
"output-file"
- (test-equal? "(get) whole-file"
- (output output-file tmp-file 'get #"text/html"
- 0 +inf.0)
- #"HTTP/1.1 206 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 81\r\nContent-Range: bytes 0-81/81\r\n\r\nA titleHere's some content!")
- (test-equal? "(get) end early"
- (output output-file tmp-file 'get #"text/html"
- 0 10)
- #"HTTP/1.1 206 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 10\r\nContent-Range: bytes 0-10/81\r\n\r\nA titleHere's some content!