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

Adding tests and updating docs

Browse Source 
svn: r6523
This commit is contained in:
Jay McCarthy 2007-06-07 21:17:27 +00:00
parent 17f6f40e92
commit 0338d621eb
5 changed files with 198 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/web-server/dispatchers/dispatch-lang.ss
View File

@ -26,9 +26,8 @@
(define (abstract-url u)
(map path/param-path
(url-path u)))
(define ans (list-prefix (abstract-url ses) (abstract-url req)))
#;(printf "~S => ~S~n" `(same-servlet? ,(url->string req) ,(url->string ses)) ans)
(and ans #t))
(list-prefix? (abstract-url ses) (abstract-url req)))
;; make-session-url: url (listof string) -> url
;; produce a new url for this session:

8
collects/web-server/docs/reference/private.scrbl
View File

@ -278,10 +278,10 @@ There are a number of other miscellaneous utilities the @file{web-server}
needs. They are provided by @file{private/util.ss}.
@subsection{Lists}
@defproc[(list-prefix [l list?]
[r list?])
(or/c list? false/c)]{
If @scheme[l] is a prefix of @scheme[r], then returns the prefix. Otherwise @scheme[#f].
@defproc[(list-prefix? [l list?]
[r list?])
boolean?]{
True if @scheme[l] is a prefix of @scheme[r].
}
@subsection{URLs}

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

@ -9,7 +9,7 @@
[url-replace-path ((list? . -> . list?) url? . -> . url?)]
[explode-path* (path? . -> . (listof (or/c symbol? path?)))]
[path-without-base (path? path? . -> . list?)]
[list-prefix (list? list? . -> . (or/c list? false/c))]
[list-prefix? (list? list? . -> . boolean?)]
[strip-prefix-ups (list? . -> . list?)] ; XXX need path-element?
[url-path->string ((listof (or/c string? path/param?)) . -> . string?)]
[network-error ((symbol? string?) (listof any/c) . ->* . (void))]
@ -20,7 +20,7 @@
[build-path-unless-absolute (path-string? path-string? . -> . path?)]
[read/string (string? . -> . serializable?)]
[write/string (serializable? . -> . string?)])
(define (read/string str)
(read (open-input-string str)))
(define (write/string v)
@ -37,7 +37,7 @@
[else
(let-values ([(base name dir?) (split-path p)])
(loop base (list* name r)))])))
; strip-prefix-ups : (listof path-element?) -> (listof path-element?)
(define (strip-prefix-ups l)
(define prefix? (box #t))
@ -52,26 +52,26 @@
; list-prefix : list? list? -> (or/c list? false/c)
; Is l a prefix or r?, and what is that prefix?
; XXX Do we need to return the prefix? isn't it ls?
(define (list-prefix ls rs)
(define (list-prefix? ls rs)
(match ls
[(list)
(list)]
#t]
[(list-rest l0 ls)
(match rs
[(list)
#f]
[(list-rest r0 rs)
(if (equal? l0 r0)
(let ([ps (list-prefix ls rs)])
(if ps (list* l0 ps) (list l0)))
#f)])]))
(list-prefix? ls rs)
#f)])]))
; path-without-base : path? path? -> (listof path-element?)
(define (path-without-base base path)
(define b (explode-path* base))
(define p (explode-path* path))
(list-tail p (length (list-prefix b p))))
(if (list-prefix? b p)
(list-tail p (length b))
(error 'path-without-base "~a is not a prefix of ~a" base path)))
;; replace-path: (url-path -> url-path) url -> url
;; make a new url by replacing the path part of a url with a function

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

@ -1,8 +1,32 @@
(module url-param-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "url.ss" "net")
(lib "url-param.ss" "web-server" "private"))
(provide url-param-tests)
; XXX
(define url0 (string->url "http://www.test.com/somewhere"))
(define url-param-tests
(test-suite
"URL Parameters")))
"URL Parameters"
(test-case
"Insert and extract is identity"
(check-equal? (extract-param (insert-param url0 "key" "val0") "key")
"val0"))
(test-case
"Insert and extract is identity after multiple"
(check-equal? (extract-param (insert-param
(insert-param url0 "key" "val0")
"key" "val1")
"key")
"val1"))
(test-case
"Insert and extract is identity after multiple different"
(check-equal? (extract-param (insert-param
(insert-param url0 "key0" "val0")
"key1" "val1")
"key0")
"val0")))))

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

@ -1,8 +1,161 @@
(module util-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "url.ss" "net")
(lib "util.ss" "web-server" "private"))
(provide util-tests)
; XXX
(define util-tests
(test-suite
"Utilities")))
"Utilities"
(test-suite
"url-replace-path"
(test-case
"Identity"
(check-equal? (url->string (url-replace-path (lambda (x) x) (string->url "http://test.com/foo/bar")))
"http://test.com/foo/bar"))
(test-case
"Remove"
(check-equal? (url->string (url-replace-path (lambda (x) (list)) (string->url "http://test.com/foo/bar")))
"http://test.com")))
(test-suite
"explode-path*"
(test-case
"Simple"
(check-equal? (explode-path* (build-path "foo" "bar"))
(list (build-path "foo") (build-path "bar")))))
(test-suite
"path-without-base"
(test-case
"Simple"
(check-equal? (path-without-base (build-path "foo")
(build-path "foo" "bar"))
(list (build-path "bar"))))
(test-case
"Exceptional case"
(check-exn (lambda _ #t)
(lambda () (path-without-base
(build-path "foo" "bar")
(build-path "foo"))))))
(test-suite
"list-prefix?"
(test-case
"Simple"
(check-true (list-prefix? '(a b c) '(a b c d))))
(test-case
"Not prefix"
(check-false (list-prefix? '(a b) '(a))))
(test-case
"Not prefix"
(check-false (list-prefix? '(a b c) '(b c d)))))
(test-suite
"strip-prefix-ups"
(test-case
"Does not apply"
(check-equal? (apply build-path (strip-prefix-ups (explode-path* (build-path "bar"))))
(build-path "bar")))
(test-case
"Applies no suffix"
(check-equal? (apply build-path (strip-prefix-ups (explode-path* (build-path 'up 'up 'up "bar"))))
(build-path "bar")))
(test-case
"Applies with suffix"
(check-equal? (apply build-path (strip-prefix-ups (explode-path* (build-path 'up 'up 'up "bar" "foo"))))
(build-path "bar" "foo"))))
(test-suite
"url-path->string"
(test-case
"Simple (no param)"
(check-equal? (url-path->string (url-path (string->url "http://test.com/foo/bar")))
"/foo/bar"))
(test-case
"Simple (param)"
(check-equal? (url-path->string (url-path (string->url "http://test.com/foo/bar;zog")))
"/foo/bar")))
(test-suite
"network-error"
(test-case
"Simple"
(check-exn exn:fail:network?
(lambda () (network-error 'foo "Bar"))))
(test-case
"Simple (format succeeds)"
(check-exn exn:fail:network?
(lambda () (network-error 'foo "Bar ~a" 1)))))
(test-suite
"directory-part"
(test-case
"Absolute"
(check-equal? (directory-part (build-path "/" "foo" "bar"))
(build-path "/" "foo/")))
(test-case
"Relative"
(check-equal? (directory-part (build-path "foo"))
(current-directory)))
(test-case
"Error"
(check-exn (lambda _ #t)
(lambda () (directory-part (build-path "/"))))))
(test-suite
"lowercase-symbol!"
(test-case
"LC String"
(check-eq? (lowercase-symbol! "foo")
'foo))
(test-case
"LC Bytes"
(check-eq? (lowercase-symbol! #"foo")
'foo))
(test-case
"UC String"
(check-eq? (lowercase-symbol! "FOO")
'foo))
(test-case
"UC Bytes"
(check-eq? (lowercase-symbol! #"FOO")
'foo)))
(test-suite
"exn->string"
(test-case
"Exception"
(check-pred string? (with-handlers ([exn? exn->string])
(error 'error "Yup"))))
(test-case
"Any"
(check-equal? (exn->string "foo")
(format "~s\n" "foo"))))
(test-suite
"build-path-unless-absolute"
(test-case
"Relative PS"
(check-equal? (build-path-unless-absolute "foo" "bar")
(build-path "foo" "bar")))
(test-case
"Absolute PS"
(check-equal? (build-path-unless-absolute "foo" "/bar")
(build-path "/bar")))
(test-case
"Relative P"
(check-equal? (build-path-unless-absolute (build-path "foo") (build-path "bar"))
(build-path "foo" "bar")))
(test-case
"Absolute P"
(check-equal? (build-path-unless-absolute (build-path "foo") (build-path "/bar"))
(build-path "/bar"))))
(test-suite
"read/string & write/string"
(test-case
"Identity"
(check-equal? (read/string (write/string (vector 1 2 3)))
(vector 1 2 3)))))))