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

Adding tests

Browse Source 
svn: r6455
This commit is contained in:
Jay McCarthy 2007-06-01 23:31:54 +00:00
parent 6f4bbf80d1
commit 636e5bd9c1
25 changed files with 110 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/web-server/private/connection-manager.ss
View File

@ -1,7 +1,3 @@
;; this is a trivial implementation of the connection-manger interface that
;; uses timeouts instead of a queued-model.
;; the queued-model is also fully implemented but won't be used at this time.
(module connection-manager mzscheme
(require "connection-structs.ss"
"timer.ss"

41
collects/web-server/private/mime-types.ss
View File

@ -4,8 +4,30 @@
(lib "string.ss"))
(require "util.ss")
(provide/contract
[read-mime-types (path? . -> . hash-table?)]
[make-get-mime-type (path? . -> . (path? . -> . bytes?))])
; read-mime-types : path? -> hash-table?
(define (read-mime-types a-path)
(define MIME-TYPE-TABLE (make-hash-table))
(with-input-from-file a-path
(lambda ()
(let loop ()
(match (read-line (current-input-port) 'any)
[(? eof-object?)
(void)]
[(regexp #"^([^\t ]+)[\t ]+(.+)$"
(list s type exts))
(for-each (lambda (ext)
(hash-table-put! MIME-TYPE-TABLE
(lowercase-symbol! ext)
type))
(regexp-split #" " exts))
(loop)]
[_
(loop)]))))
MIME-TYPE-TABLE)
;; make-get-mime-type : path? -> path? -> bytes?
;; determine the mime type based on the filename's suffix
;;
@ -13,25 +35,10 @@
;; 1. Can we determine the mime type based on file contents?
;; 2. Assuming that 7-bit ASCII is correct for mime-type
(define (make-get-mime-type a-path)
(let ([MIME-TYPE-TABLE (make-hash-table)]
(let ([MIME-TYPE-TABLE (read-mime-types a-path)]
[DEFAULT-MIME-TYPE #"text/plain; charset=utf-8"]
[file-suffix-regexp (byte-regexp #".*\\.([^\\.]*$)")])
(with-input-from-file a-path
(lambda ()
(let loop ()
(match (read-line (current-input-port) 'any)
[(? eof-object?)
(void)]
[(regexp #"^([^\t ]+)[\t ]+(.+)$"
(list s type exts))
(for-each (lambda (ext)
(hash-table-put! MIME-TYPE-TABLE
(lowercase-symbol! ext)
type))
(regexp-split #" " exts))
(loop)]
[_
(loop)]))))
(lambda (path)
(match (regexp-match file-suffix-regexp (path->bytes path))
[(list path-bytes sffx)

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

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide dispatch-files-tests)
; XXX
(define dispatch-files-tests
(test-suite
"Files")))

1
collects/web-server/tests/dispatchers/dispatch-lang-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide dispatch-lang-tests)
; XXX
(define dispatch-lang-tests
(test-suite
"Web Language")))

1
collects/web-server/tests/dispatchers/dispatch-passwords-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide dispatch-passwords-tests)
; XXX
(define dispatch-passwords-tests
(test-suite
"Passwords")))

1
collects/web-server/tests/dispatchers/dispatch-servlets-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide dispatch-servlets-tests)
; XXX
(define dispatch-servlets-tests
(test-suite
"Servlets")))

1
collects/web-server/tests/lang/abort-resume-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide abort-resume-tests)
; XXX
(define abort-resume-tests
(test-suite
"Abort Resume")))

1
collects/web-server/tests/lang/web-cells-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide web-cells-tests)
; XXX
(define web-cells-tests
(test-suite
"Web Cells")))

1
collects/web-server/tests/lang/web-extras-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide web-extras-tests)
; XXX
(define web-extras-tests
(test-suite
"Web Extras")))

1
collects/web-server/tests/lang/web-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide web-tests)
; XXX
(define web-tests
(test-suite
"Web")))

1
collects/web-server/tests/private/cache-table-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide cache-table-tests)
; XXX
(define cache-table-tests
(test-suite
"Cache Table")))

1
collects/web-server/tests/private/connection-manager-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide connection-manager-tests)
; XXX
(define connection-manager-tests
(test-suite
"Connection Manager")))

39
collects/web-server/tests/private/mime-types-test.ss
View File

@ -1,7 +1,42 @@
(module mime-types-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "file.ss")
(lib "mime-types.ss" "web-server" "private"))
(provide mime-types-tests)
(define test-file (make-temporary-file))
(with-output-to-file test-file
(lambda ()
(printf #<<END
video/mp4 mp4
video/mpeg mpeg mpg mpe
END
))
'replace)
(define mime-types-tests
(test-suite
"MIME Types")))
"MIME Types"
(test-case
"Distribution mime.types parses"
(check-not-false (read-mime-types (build-path (collection-path "web-server") "default-web-root" "mime.types"))))
(test-case
"Test file parses"
(check-not-false (read-mime-types test-file)))
(test-case
"Default mime-type given"
(check-equal? ((make-get-mime-type test-file) (build-path "test.html")) #"text/plain; charset=utf-8"))
(test-case
"MIME type resolves (single in file)"
(check-equal? ((make-get-mime-type test-file) (build-path "test.mp4")) #"video/mp4"))
(test-case
"MIME type resolves (multiple in file)"
(check-equal? ((make-get-mime-type test-file) (build-path "test.mpeg")) #"video/mpeg"))
(test-case
"MIME type resolves (multiple in file)"
(check-equal? ((make-get-mime-type test-file) (build-path "test.mpg")) #"video/mpeg"))
(test-case
"MIME type resolves (multiple in file)"
(check-equal? ((make-get-mime-type test-file) (build-path "test.mpe")) #"video/mpeg")))))

1
collects/web-server/tests/private/request-test.ss
View File

@ -36,6 +36,7 @@
(lambda (f s) s)))
; XXX
(define request-tests
(test-suite
"Request Parsing"

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

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide response-tests)
; XXX
(define response-tests
(test-suite
"HTTP Responses")))

1
collects/web-server/tests/private/servlet-test.ss
View File

@ -3,6 +3,7 @@
(lib "servlet.ss" "web-server"))
(provide servlet-tests)
; XXX
(define servlet-tests
(test-suite
"Servlets")))

1
collects/web-server/tests/private/session-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide session-tests)
; XXX
(define session-tests
(test-suite
"Sessions")))

1
collects/web-server/tests/private/url-param-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide url-param-tests)
; XXX
(define url-param-tests
(test-suite
"URL Parameters")))

1
collects/web-server/tests/private/util-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide util-tests)
; XXX
(define util-tests
(test-suite
"Utilities")))

1
collects/web-server/tests/servlet-test.ss
View File

@ -3,6 +3,7 @@
(lib "servlet.ss" "web-server"))
(provide servlet-tests)
; XXX
(define servlet-tests
(test-suite
"Servlets")))

1
collects/web-server/tests/servlet/basic-auth-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide basic-auth-tests)
; XXX
(define basic-auth-tests
(test-suite
"BASIC Authentication")))

30
collects/web-server/tests/servlet/bindings-test.ss
View File

@ -1,7 +1,33 @@
(module bindings-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "bindings.ss" "web-server" "servlet"))
(provide bindings-tests)
(define bs `([foo . 3] [foos . 1] [foos . 2]))
(define bindings-tests
(test-suite
"Bindings")))
"Bindings"
(test-case
"exists-binding? - true"
(check-true (exists-binding? 'foo bs)))
(test-case
"exists-binding? - false"
(check-false (exists-binding? 'bar bs)))
(test-case
"extract-bindings"
(check-equal? (extract-bindings 'foos bs) (list 1 2)))
(test-case
"extract-binding/single - success"
(check-equal? (extract-binding/single 'foo bs) 3))
(test-case
"extract-binding/single - failure"
(check-exn (lambda (exn) (regexp-match "not found" (exn-message exn)))
(lambda () (extract-binding/single 'bar bs) 3)))
(test-case
"extract-binding/single - multiple"
(check-exn (lambda (exn) (regexp-match "multiple times" (exn-message exn)))
(lambda () (extract-binding/single 'foos bs) 3))))))

1
collects/web-server/tests/servlet/helpers-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide helpers-tests)
; XXX
(define helpers-tests
(test-suite
"Helpers")))

1
collects/web-server/tests/servlet/servlet-url-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide servlet-url-tests)
; XXX
(define servlet-url-tests
(test-suite
"Servlet URLs")))

1
collects/web-server/tests/servlet/web-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(provide web-tests)
; XXX
(define web-tests
(test-suite
"Web")))