#lang scheme
(require schemeunit
(only-in mzlib/file
file-name-from-path
make-temporary-file)
net/url
mzlib/list
xml/xml
web-server/http
web-server/private/util
web-server/dispatchers/dispatch
(prefix-in files: web-server/dispatchers/dispatch-files)
"../util.ss")
(require/expose web-server/dispatchers/dispatch-files
(looks-like-directory?))
(provide dispatch-files-tests)
(define tmp-file (make-temporary-file))
(with-output-to-file tmp-file
(lambda ()
(display
(xexpr->string
`(html (head (title "A title"))
(body "Here's some content!")))))
#:exists 'truncate/replace)
(define a-dir (directory-part tmp-file))
(define not-there (build-path "I/probably/do/not/exist"))
(define (dispatch i? . paths)
(define b (box 0))
(files:make #:url->path
(lambda (url)
(begin0 (values (list-ref paths (min (unbox b) (sub1 (length paths)))) empty)
(set-box! b (add1 (unbox b)))))
#:indices (list (if i? (file-name-from-path tmp-file) not-there))))
(define file-url (string->url "http://test.com/foo"))
(define dir-url (string->url "http://test.com/foo/"))
(define (req d? meth heads)
(make-request meth (if d? dir-url file-url) heads empty #"" "host" 80 "client"))
(define dispatch-files-tests
(test-suite
"Files"
(local [(define (yes s) (test-not-false s (looks-like-directory? s)))
(define (no s) (test-false s (looks-like-directory? s)))]
(test-suite
"Looks like directory"
(no "") (no "foo") (no "/foo") (no "/foo/bar")
(yes "/") (yes "/foo/") (yes "foo/" )(yes "/bar/zog/trog/")))
(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 (parameterize ([current-error-port (open-output-nowhere)])
(files:read-range-header (list (make-header #"Range" #"completely wrong")))) "check 2")
(check-false (parameterize ([current-error-port (open-output-nowhere)])
(files:read-range-header (list (make-header #"Range" #"byte=1-10")))) "check 3")
(check-false (parameterize ([current-error-port (open-output-nowhere)])
(files:read-range-header (list (make-header #"Range" #"bytes=a-10")))) "check 4")
(check-false (parameterize ([current-error-port (open-output-nowhere)])
(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 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 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-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!