pr8984
svn: r7500
This commit is contained in:
Jay McCarthy
parent
b99623c7ec
commit
43a14f0767
|
|
@ -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)]))))
|
||||
(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)))))
|
||||
|
||||
)
|
||||
|
|
@ -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)))
|
||||
(ext:wrap output-response/method))
|
||||
|
||||
)
|
||||
|
|
@ -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\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
(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\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
(test-equal? "file, exists, whole, no Range, head"
|
||||
(collect (dispatch #t tmp-file) (req #f 'head empty))
|
||||
#"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\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
(test-equal? "file, exists, whole, Range, head"
|
||||
(collect (dispatch #t tmp-file) (req #f 'head (list (make-header #"Range" #"bytes=0-80"))))
|
||||
#"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><head><ti")
|
||||
(collect (dispatch #t tmp-file) (req #f 'get (list (make-header #"Range" #"bytes=5-9"))))
|
||||
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 5\r\nContent-Range: bytes 5-9/81\r\n\r\n><hea")
|
||||
(test-equal? "file, exists, part, head"
|
||||
(collect (dispatch #t tmp-file) (req #f 'head (list (make-header #"Range" #"bytes=5-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")
|
||||
(collect (dispatch #t tmp-file) (req #f 'head (list (make-header #"Range" #"bytes=5-9"))))
|
||||
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 5\r\nContent-Range: bytes 5-9/81\r\n\r\n")
|
||||
|
||||
(test-exn "path, non"
|
||||
exn:dispatcher?
|
||||
(lambda () (collect (dispatch #t not-there) (req #f 'get empty))))
|
||||
|
||||
(test-equal? "dir, exists, get"
|
||||
(test-equal? "dir, exists, no Range, get"
|
||||
(collect (dispatch #t a-dir) (req #t '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\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
(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\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
(test-equal? "dir, exists, no Range, head"
|
||||
(collect (dispatch #t a-dir) (req #t 'head empty))
|
||||
#"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\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
(test-equal? "dir, exists, Range, head"
|
||||
(collect (dispatch #t a-dir) (req #t 'head (list (make-header #"Range" #"bytes=0-80"))))
|
||||
#"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")
|
||||
|
|
|
|||
|
|
@ -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\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
(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\n<html><hea")
|
||||
(test-equal? "(get) start late"
|
||||
(output output-file tmp-file 'get #"text/html"
|
||||
10 +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: 71\r\nContent-Range: bytes 10-81/81\r\n\r\nd><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
(test-equal? "(get) start late and end early"
|
||||
(output output-file tmp-file 'get #"text/html"
|
||||
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\r\nContent-Length: 5\r\nContent-Range: bytes 5-10/81\r\n\r\n><head><ti")
|
||||
(test-equal? "(head) whole-file"
|
||||
(output output-file tmp-file 'head #"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\n")
|
||||
(test-equal? "(head) end early"
|
||||
(output output-file tmp-file 'head #"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\n")
|
||||
(test-equal? "(head) start late"
|
||||
(output output-file tmp-file 'head #"text/html"
|
||||
10 +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: 71\r\nContent-Range: bytes 10-81/81\r\n\r\n")
|
||||
(test-equal? "(head) start late and end early"
|
||||
(output output-file tmp-file 'head #"text/html"
|
||||
1 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: 9\r\nContent-Range: bytes 1-10/81\r\n\r\n"))))))
|
||||
|
||||
(test-equal? "(get) whole file - no Range header"
|
||||
(output output-file tmp-file 'get #"text/html" #f)
|
||||
#"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
|
||||
(test-equal? "(get) whole file - Range header present"
|
||||
(output output-file tmp-file 'get #"text/html" '((0 . 80)))
|
||||
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
|
||||
(test-equal? "(get) single range - suffix range larger than file"
|
||||
(output output-file tmp-file 'get #"text/html" '((#f . 90)))
|
||||
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n<html><head><title>A title</title></head><body>Here's some content!</body></html>")
|
||||
|
||||
(test-equal? "(get) single range - 10 bytes from the start"
|
||||
(output output-file tmp-file 'get #"text/html" '((0 . 9)))
|
||||
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 10\r\nContent-Range: bytes 0-9/81\r\n\r\n<html><hea")
|
||||
|
||||
(test-equal? "(get) single range - 10 bytes from the end"
|
||||
(output output-file tmp-file 'get #"text/html" '((71 . #f)))
|
||||
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 10\r\nContent-Range: bytes 71-80/81\r\n\r\ndy></html>")
|
||||
|
||||
(test-equal? "(get) single range - 10 bytes from past the end"
|
||||
(output output-file tmp-file 'get #"text/html" '((76 . 86)))
|
||||
#"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)))
|
||||
#"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nAccept-Ranges: bytes\r\nContent-Length: 10\r\nContent-Range: bytes 10-19/81\r\n\r\nd><title>A")
|
||||
|
||||
(test-equal? "(get) multiple ranges"
|
||||
(output output-file/boundary tmp-file 'get #"text/html" '((10 . 19) (30 . 39) (50 . 59)) #"BOUNDARY")
|
||||
#"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")
|
||||
#"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")
|
||||
#"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)
|
||||
#"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)))
|
||||
#"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)))
|
||||
#"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)))
|
||||
#"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)))
|
||||
#"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")
|
||||
#"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")
|
||||
#"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")
|
||||
#"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")
|
||||
|
||||
))))
|
||||
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user