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

Adding tests and fixing things

Browse Source 
svn: r6454
This commit is contained in:
Jay McCarthy 2007-06-01 22:52:44 +00:00
parent 49e542f71d
commit 6f4bbf80d1
8 changed files with 157 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/web-server/dispatchers/filesystem-map.ss
View File

@ -26,7 +26,9 @@
; XXX Should error?
(strip-prefix-ups
(map (lambda (p)
(if (string=? "" p) 'same p))
(if (and (string? p) (string=? "" p))
'same
p))
; Extract the paths from the url-path
(map path/param-path
(url-path u)))))

2
collects/web-server/lang/file-box.ss
View File

@ -19,7 +19,7 @@
(define (file-unbox fb)
(deserialize (call-with-input-file (internal-file-box-path fb) read)))
(define (file-box-set! fb v)
(with-output-to-file (internal-file-box-path fb) (lambda () (write (serialize v)))))
(with-output-to-file (internal-file-box-path fb) (lambda () (write (serialize v))) 'replace))
(provide/contract
[file-box? (any/c . -> . boolean?)]

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

@ -8,6 +8,7 @@
(provide
url-replace-path)
(provide/contract
[explode-path* (path? . -> . (listof (or/c symbol? path?)))]
[path-without-base (path? path? . -> . list?)]
[list-prefix (list? list? . -> . (or/c list? false/c))]
[strip-prefix-ups (list? . -> . list?)] ; XXX need path-element?

17
collects/web-server/tests/configuration/configuration-table-test.ss
View File

@ -1,7 +1,20 @@
(module configuration-table-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "file.ss")
(lib "configuration-table.ss" "web-server" "configuration")
(lib "web-config-unit.ss" "web-server"))
(provide configuration-table-tests)
(define configuration-table-tests
(test-suite
"Configuration Table")))
"Configuration Table"
(test-case
"Default configuration file may be parsed"
(check-not-false (read-configuration-table default-configuration-table-path)))
(test-case
"Default configuration file may be written"
(check-not-false (write-configuration-table
(read-configuration-table default-configuration-table-path)
(make-temporary-file)))))))

54
collects/web-server/tests/dispatchers/filesystem-map-test.ss
View File

@ -1,7 +1,57 @@
(module filesystem-map-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "kw.ss")
(lib "url.ss" "net")
(lib "util.ss" "web-server" "private")
(lib "filesystem-map.ss" "web-server" "dispatchers"))
(provide filesystem-map-tests)
(define base-dir (collection-path "web-server"))
(define test-map (make-url->path base-dir))
(define test-map/optimism (make-url->path/optimism test-map))
(define/kw (test-url->path url->path file
#:key
[url-string
(format "http://test.com/~a" (path->string file))]
[expected file])
(define vs
(call-with-values
(lambda () (url->path (string->url url-string)))
(lambda vs vs)))
(check-equal? vs (list (build-path base-dir expected) (explode-path* expected))))
(define filesystem-map-tests
(test-suite
"Filesystem Map")))
"Filesystem Map"
(test-suite
"url->path"
(test-case "Simple case"
(test-url->path test-map (build-path "dispatchers/filesystem-map.ss")))
(test-case "Strips parameters"
(test-url->path test-map (build-path "dispatchers/filesystem-map.ss")
#:url-string "http://test.com/dispatchers/filesystem-map.ss;foo"))
(test-case "Strips outs bad '..'s"
(test-url->path test-map (build-path "dispatchers/filesystem-map.ss")
#:url-string "http://test.com/../../dispatchers/filesystem-map.ss"))
(test-case "Leaves in good '..'s"
(test-url->path test-map (build-path "dispatchers/../dispatchers/filesystem-map.ss"))))
(test-suite
"url->path/optimism"
(test-suite
"Preserves url->path"
(test-case "Simple case"
(test-url->path test-map/optimism (build-path "dispatchers/filesystem-map.ss")))
(test-case "Strips parameters"
(test-url->path test-map/optimism (build-path "dispatchers/filesystem-map.ss")
#:url-string "http://test.com/dispatchers/filesystem-map.ss;foo"))
(test-case "Strips outs bad '..'s"
(test-url->path test-map/optimism (build-path "dispatchers/filesystem-map.ss")
#:url-string "http://test.com/../../dispatchers/filesystem-map.ss"))
(test-case "Leaves in good '..'s"
(test-url->path test-map/optimism (build-path "dispatchers/../dispatchers/filesystem-map.ss"))))
(test-case "Finds valid path underneath"
(test-url->path test-map/optimism (build-path "dispatchers/filesystem-map.ss/not-a-file")
#:expected (build-path "dispatchers/filesystem-map.ss")))))))

24
collects/web-server/tests/lang/file-box-test.ss
View File

@ -1,7 +1,27 @@
(module file-box-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "file-box.ss" "web-server" "lang")
(lib "file.ss"))
(provide file-box-tests)
(define file-box-tests
(test-suite
"File Boxes")))
"File Boxes"
(test-case
"Creating a file box"
(check-not-false (file-box (make-temporary-file) 42)))
(test-case
"Reading a file box"
(check-equal? (file-unbox (file-box (make-temporary-file) 42)) 42))
(test-case
"Writing a file box"
(check-not-false (file-box-set! (file-box (make-temporary-file) 42) 43)))
(test-case
"Reading and Writing a file box"
(check-equal? (let ([fb (file-box (make-temporary-file) 42)])
(file-box-set! fb 43)
(file-unbox fb))
43)))))

41
collects/web-server/tests/lang/stuff-url-test.ss
View File

@ -1,21 +1,19 @@
(module stuff-url-test mzscheme
(require (lib "stuff-url.ss" "web-server" "lang")
(lib "mod-map.ss" "web-server" "private")
(planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "url.ss" "net")
(lib "serialize.ss")
"../util.ss")
(provide stuff-url-tests)
(define uri0 (string->url "www.google.com"))
(define (simplify-unsimplify v)
(decompress-serial
(compress-serial
v)))
(define (stuff-unstuff svl uri)
(let ([result-uri (stuff-url svl uri)])
(unstuff-url result-uri)))
(define (cidentity v)
(deserialize
(stuff-unstuff (serialize v) uri0)))
(define the-dispatch
`(lambda (k*v)
@ -28,23 +26,24 @@
(define stuff-url-tests
(test-suite
"Stuff URL"
(test-suite
"(compose unstuff-url stuff-url) is identity"
(test-case "Integers" (check-equal? (cidentity 3) 3))
(test-case "Symbols" (check-equal? (cidentity 'foo) 'foo))
(test-case "Strings" (check-equal? (cidentity "Bar") "Bar"))
(test-case "Vectors" (check-equal? (cidentity (vector 3 1 4)) (vector 3 1 4))))
(test-case
"compose url-parts and recover-serial (1)"
(let-values ([(ev) (make-eval/mod-path m00)])
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start start 'foo))))]
[k1 (simplify-unsimplify (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) 1)))))]
[k2 (simplify-unsimplify (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k1) 2)))))])
(check-true (= 6 (ev `(dispatch ,the-dispatch (list (deserialize ',k2) 3))))))))
(test-case
"compose url-parts and recover-serial (2)"
(let-values ([(ev) (make-eval/mod-path m01)])
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start start 'foo))))])
(check-true (= 7 (ev `(dispatch ,the-dispatch (list (deserialize ',k0) 7))))))))
(test-suite
"stuffed-url? works"
(test-case "Not stuffed URL" (check-false (stuffed-url? uri0)))
(test-case "Integers" (check-true (stuffed-url? (stuff-url (serialize 3) uri0))))
(test-case "Symbols" (check-true (stuffed-url? (stuff-url (serialize 'foo) uri0))))
(test-case "Strings" (check-true (stuffed-url? (stuff-url (serialize "Bar") uri0))))
(test-case "Vectors" (check-true (stuffed-url? (stuff-url (serialize (vector 3 1 4)) uri0)))))
(test-case
"compose stuff-url and unstuff-url and recover the serial"
"Using stuff-url with lang.ss"
(let-values ([(ev) (make-eval/mod-path m00)])
(let* ([k0 (stuff-unstuff (ev '(serialize (dispatch-start start 'foo)))
uri0)]

45
collects/web-server/tests/private/mod-map-test.ss
View File

@ -1,7 +1,48 @@
(module mod-map-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "mod-map.ss" "web-server" "private")
(lib "serialize.ss")
"../util.ss")
(provide mod-map-tests)
(define (simplify-unsimplify v)
(decompress-serial
(compress-serial
v)))
(define (cidentity v)
(deserialize
(simplify-unsimplify
(serialize v))))
(define the-dispatch
`(lambda (k*v)
(lambda (k*v)
((car k*v) k*v))))
(define m00 '(lib "mm00.ss" "web-server" "default-web-root" "htdocs" "lang-servlets"))
(define m01 '(lib "mm01.ss" "web-server" "default-web-root" "htdocs" "lang-servlets"))
(define mod-map-tests
(test-suite
"Module Map")))
"Module Map"
(test-suite
"(compose decompress-serial compress-serial) is identity"
(test-case "Integers" (check-equal? (cidentity 3) 3))
(test-case "Symbols" (check-equal? (cidentity 'foo) 'foo))
(test-case "Strings" (check-equal? (cidentity "Bar") "Bar"))
(test-case "Vectors" (check-equal? (cidentity (vector 3 1 4)) (vector 3 1 4))))
(test-case
"Use compress-serial and decompress-serial with lang.ss (1)"
(let-values ([(ev) (make-eval/mod-path m00)])
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start start 'foo))))]
[k1 (simplify-unsimplify (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) 1)))))]
[k2 (simplify-unsimplify (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k1) 2)))))])
(check-true (= 6 (ev `(dispatch ,the-dispatch (list (deserialize ',k2) 3))))))))
(test-case
"Use compress-serial and decompress-serial with lang.ss (2)"
(let-values ([(ev) (make-eval/mod-path m01)])
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start start 'foo))))])
(check-true (= 7 (ev `(dispatch ,the-dispatch (list (deserialize ',k0) 7)))))))))))