Adding tests and fixing things
svn: r6454
This commit is contained in:
parent
49e542f71d
commit
6f4bbf80d1
|
@ -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)))))
|
||||
|
|
|
@ -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?)]
|
||||
|
|
|
@ -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?
|
||||
|
|
|
@ -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)))))))
|
|
@ -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")))))))
|
|
@ -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)))))
|
|
@ -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)]
|
||||
|
|
|
@ -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)))))))))))
|
Loading…
Reference in New Issue
Block a user