suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Testing tools and dispatch-files tests

Browse Source 
svn: r6554
This commit is contained in:
Jay McCarthy 2007-06-09 04:45:23 +00:00
parent d5415954bc
commit d42ec59149
6 changed files with 112 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/web-server/dispatchers/dispatch-files.ss
View File

@ -50,12 +50,12 @@
; XXX: Unhandled range: r
(output-file conn path method (get-mime-type path)
0 +inf.0)])])]
[(directory-exists? path)
[(and (directory-exists? path)
(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 (and (file-exists? full-name)
(looks-like-directory? (url-path->string (url-path uri))))
(when (file-exists? full-name)
(esc (output-file conn full-name method (get-mime-type full-name)
0 +inf.0))))
indices)

13
collects/web-server/private/request-structs.ss
View File

@ -54,9 +54,10 @@
(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?] [uri url?]
[headers/raw (listof header?)]
[bindings/raw (listof binding?)]
[post-data/raw (or/c false/c bytes?)]
[host-ip string?] [host-port number?]
[client-ip string?])]))
[struct request ([method symbol?]
[uri url?]
[headers/raw (listof header?)]
[bindings/raw (listof binding?)]
[post-data/raw (or/c false/c bytes?)]
[host-ip string?] [host-port number?]
[client-ip string?])]))

1
collects/web-server/private/response.ss
View File

@ -201,6 +201,7 @@
(define bresp
(make-response/basic 206 "Okay" (file-or-directory-modify-seconds file-path) mime-type
(list (cons 'Content-Length (number->string len))
; XXX Remove on non-gets?
(cons 'Content-Range (format "bytes ~a-~a/~a" start end total-len)))))
(output-headers+response/basic conn bresp)
(when (eq? method 'get)

78
collects/web-server/tests/dispatchers/dispatch-files-test.ss
View File

@ -1,8 +1,80 @@
(module dispatch-files-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "file.ss")
(lib "url.ss" "net")
(lib "list.ss")
(lib "xml.ss" "xml")
(lib "request-structs.ss" "web-server" "private")
(lib "util.ss" "web-server" "private")
(lib "dispatch.ss" "web-server" "dispatchers")
(prefix files: (lib "dispatch-files.ss" "web-server" "dispatchers"))
"../util.ss")
(provide dispatch-files-tests)
; XXX
(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!")))))
'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)))))
#:mime-types-path (build-path "/etc/httpd/mime.types")
#:indices (list (if i? (file-name-from-path tmp-file) not-there))))
(define (collect d req)
(define-values (c i o) (make-mock-connection #""))
(d c req)
(redact (get-output-bytes o)))
(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")))
"Files"
(test-equal? "file, exists, whole, 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/plain; 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"
(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/plain; charset=utf-8\r\nContent-Length: 81\r\nContent-Range: bytes 0-81/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/plain; charset=utf-8\r\nContent-Length: 5\r\nContent-Range: bytes 5-10/81\r\n\r\n><head><ti")
(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/plain; charset=utf-8\r\nContent-Length: 5\r\nContent-Range: bytes 5-10/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"
(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/plain; 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"
(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/plain; charset=utf-8\r\nContent-Length: 81\r\nContent-Range: bytes 0-81/81\r\n\r\n")
(test-exn "dir, not dir-url, get"
exn:dispatcher?
(lambda () (collect (dispatch #t a-dir) (req #f 'get empty))))
(test-exn "dir, not exists, get"
exn:dispatcher?
(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)))))))

21
collects/web-server/tests/private/response-test.ss
View File

@ -4,28 +4,13 @@
(lib "file.ss")
(lib "response.ss" "web-server" "private")
(lib "response-structs.ss" "web-server" "private")
(lib "connection-manager.ss" "web-server" "private")
(lib "timer.ss" "web-server" "private"))
"../util.ss")
(provide response-tests)
(define (make-mock-connection ib)
(define ip (open-input-bytes ib))
(define op (open-output-bytes))
(values (make-connection (make-timer never-evt +inf.0 (lambda () (void)))
ip op (make-custodian) #f (make-semaphore 1))
ip
op))
(define (output f . any)
(define-values (c i o) (make-mock-connection #""))
(apply f c any)
(regexp-replace
#"Date: [a-zA-Z0-9:, ]+ GMT\r\n"
(regexp-replace
#"Last-Modified: [a-zA-Z0-9:, ]+ GMT\r\n"
(get-output-bytes o)
#"Last-Modified: REDACTED GMT\r\n")
#"Date: REDACTED GMT\r\n"))
(redact (get-output-bytes o)))
(define response-tests
(test-suite

25
collects/web-server/tests/util.ss
View File

@ -1,6 +1,27 @@
(module util mzscheme
(require (lib "connection-manager.ss" "web-server" "private")
(lib "timer.ss" "web-server" "private"))
(provide make-module-eval
make-eval/mod-path)
make-eval/mod-path
make-mock-connection
redact)
(define (make-mock-connection ib)
(define ip (open-input-bytes ib))
(define op (open-output-bytes))
(values (make-connection (make-timer never-evt +inf.0 (lambda () (void)))
ip op (make-custodian) #f (make-semaphore 1))
ip
op))
(define (redact b)
(regexp-replace
#"Date: [a-zA-Z0-9:, ]+ GMT\r\n"
(regexp-replace
#"Last-Modified: [a-zA-Z0-9:, ]+ GMT\r\n"
b
#"Last-Modified: REDACTED GMT\r\n")
#"Date: REDACTED GMT\r\n"))
(define-syntax (make-module-eval m-expr)
(syntax-case m-expr (module)
@ -14,7 +35,7 @@
(lambda (s-expr)
(parameterize ([current-namespace ns])
(eval s-expr))))]
(eval s-expr))))]
[else
(raise-syntax-error #f "make-module-evel: dropped through" m-expr)]))