From 6f4bbf80d183054e981d0dc735f529be19856cef Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 1 Jun 2007 22:52:44 +0000 Subject: [PATCH] Adding tests and fixing things svn: r6454 --- .../web-server/dispatchers/filesystem-map.ss | 4 +- collects/web-server/lang/file-box.ss | 2 +- collects/web-server/private/util.ss | 1 + .../configuration/configuration-table-test.ss | 17 +++++- .../tests/dispatchers/filesystem-map-test.ss | 54 ++++++++++++++++++- .../web-server/tests/lang/file-box-test.ss | 24 ++++++++- .../web-server/tests/lang/stuff-url-test.ss | 41 +++++++------- .../web-server/tests/private/mod-map-test.ss | 45 +++++++++++++++- 8 files changed, 157 insertions(+), 31 deletions(-) diff --git a/collects/web-server/dispatchers/filesystem-map.ss b/collects/web-server/dispatchers/filesystem-map.ss index 4f1ff6c15a..a7355316c6 100644 --- a/collects/web-server/dispatchers/filesystem-map.ss +++ b/collects/web-server/dispatchers/filesystem-map.ss @@ -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))))) diff --git a/collects/web-server/lang/file-box.ss b/collects/web-server/lang/file-box.ss index fda2ddedef..dd59f2541f 100644 --- a/collects/web-server/lang/file-box.ss +++ b/collects/web-server/lang/file-box.ss @@ -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?)] diff --git a/collects/web-server/private/util.ss b/collects/web-server/private/util.ss index 54786537f1..f47a2ae8f7 100644 --- a/collects/web-server/private/util.ss +++ b/collects/web-server/private/util.ss @@ -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? diff --git a/collects/web-server/tests/configuration/configuration-table-test.ss b/collects/web-server/tests/configuration/configuration-table-test.ss index c437aead7c..42fdb65aed 100644 --- a/collects/web-server/tests/configuration/configuration-table-test.ss +++ b/collects/web-server/tests/configuration/configuration-table-test.ss @@ -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"))) \ No newline at end of file + "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))))))) \ No newline at end of file diff --git a/collects/web-server/tests/dispatchers/filesystem-map-test.ss b/collects/web-server/tests/dispatchers/filesystem-map-test.ss index c490868515..8dcdc4afb4 100644 --- a/collects/web-server/tests/dispatchers/filesystem-map-test.ss +++ b/collects/web-server/tests/dispatchers/filesystem-map-test.ss @@ -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"))) \ No newline at end of file + "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"))))))) \ No newline at end of file diff --git a/collects/web-server/tests/lang/file-box-test.ss b/collects/web-server/tests/lang/file-box-test.ss index b494001e87..3ef2d08437 100644 --- a/collects/web-server/tests/lang/file-box-test.ss +++ b/collects/web-server/tests/lang/file-box-test.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"))) \ No newline at end of file + "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))))) \ No newline at end of file diff --git a/collects/web-server/tests/lang/stuff-url-test.ss b/collects/web-server/tests/lang/stuff-url-test.ss index ab243980c1..e96ced0c30 100644 --- a/collects/web-server/tests/lang/stuff-url-test.ss +++ b/collects/web-server/tests/lang/stuff-url-test.ss @@ -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)] diff --git a/collects/web-server/tests/private/mod-map-test.ss b/collects/web-server/tests/private/mod-map-test.ss index 227b26c19d..8d58634ddb 100644 --- a/collects/web-server/tests/private/mod-map-test.ss +++ b/collects/web-server/tests/private/mod-map-test.ss @@ -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"))) \ No newline at end of file + "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))))))))))) \ No newline at end of file