Supporting methods in web-server/dispatch
This commit is contained in:
Jay McCarthy
parent
8b035f3c73
commit
211e869fe1
|
|
@ -14,47 +14,47 @@
|
|||
web-server/dispatch/container)
|
||||
(provide all-dispatch-tests)
|
||||
|
||||
(define (test-request url)
|
||||
(make-request #"GET" url null (delay null) #f "1.2.3.4" 123 "4.3.2.1"))
|
||||
(define (test-request url #:method [method #"GET"])
|
||||
(make-request method url null (delay null) #f "1.2.3.4" 123 "4.3.2.1"))
|
||||
|
||||
(define all-dispatch-tests
|
||||
(test-suite
|
||||
"Dispatch"
|
||||
|
||||
|
||||
#;(local
|
||||
[(define-syntax test-match=>
|
||||
(syntax-rules ()
|
||||
[(_ val pat res)
|
||||
(test-equal? (format "~S" 'pat)
|
||||
(match=> val [pat => (lambda x x)])
|
||||
res)]))]
|
||||
(test-suite
|
||||
"match"
|
||||
|
||||
(test-match=> (list 1 2) (list a b) (list 1 2))
|
||||
(test-match=> (list 1 2) (list _ b) (list 2))))
|
||||
|
||||
[(define-syntax test-match=>
|
||||
(syntax-rules ()
|
||||
[(_ val pat res)
|
||||
(test-equal? (format "~S" 'pat)
|
||||
(match=> val [pat => (lambda x x)])
|
||||
res)]))]
|
||||
(test-suite
|
||||
"match"
|
||||
|
||||
(test-match=> (list 1 2) (list a b) (list 1 2))
|
||||
(test-match=> (list 1 2) (list _ b) (list 2))))
|
||||
|
||||
(test-suite
|
||||
"coercion"
|
||||
|
||||
|
||||
(test-suite "make-coerce-safe?"
|
||||
(local [(define string->number? (make-coerce-safe? string->number))]
|
||||
(test-not-false "1" (string->number? "1"))
|
||||
(test-not-false "1.2" (string->number? "1.2"))
|
||||
(test-not-false "+inf.0" (string->number? "+inf.0"))
|
||||
(test-false "a" (string->number? "a"))))
|
||||
|
||||
|
||||
(test-not-false "1" (string->number? "1"))
|
||||
(test-not-false "1.2" (string->number? "1.2"))
|
||||
(test-not-false "+inf.0" (string->number? "+inf.0"))
|
||||
(test-false "a" (string->number? "a"))))
|
||||
|
||||
|
||||
(test-suite "define-coercion-match-expander"
|
||||
(local [(define string->number? (make-coerce-safe? string->number))
|
||||
(define-coercion-match-expander string->number/m string->number? string->number)
|
||||
(define (test i r)
|
||||
(test-equal? i (match i [(string->number/m a) a] [_ #f]) r))]
|
||||
(test "1" 1)
|
||||
(test "1.2" 1.2)
|
||||
(test "+inf.0" +inf.0)
|
||||
(test "a" #f))))
|
||||
|
||||
(test "1" 1)
|
||||
(test "1.2" 1.2)
|
||||
(test "+inf.0" +inf.0)
|
||||
(test "a" #f))))
|
||||
|
||||
(local [(define string->number? (make-coerce-safe? string->number))
|
||||
(define-coercion-match-expander string->number/m string->number? string->number)
|
||||
(define-coercion-match-expander number->string/m number? number->string)
|
||||
|
|
@ -65,62 +65,62 @@
|
|||
(test-suite (format "~S" (list i r))
|
||||
(test-equal? (format "~S" i)
|
||||
(syntax-parameterize ([bidi-match-going-in? #t])
|
||||
(match i [(number-arg a) a] [_ #f]))
|
||||
(match i [(number-arg a) a] [_ #f]))
|
||||
r)
|
||||
(test-equal? (format "~S" r)
|
||||
(syntax-parameterize ([bidi-match-going-in? #f])
|
||||
(match r [(number-arg a) a] [_ #f]))
|
||||
(match r [(number-arg a) a] [_ #f]))
|
||||
i))]
|
||||
|
||||
|
||||
[i
|
||||
(test-equal? (format "~S" i)
|
||||
(syntax-parameterize ([bidi-match-going-in? #t])
|
||||
(match i [(number-arg a) a] [_ #f]))
|
||||
(match i [(number-arg a) a] [_ #f]))
|
||||
r)]
|
||||
[r
|
||||
(test-equal? (format "~S" r)
|
||||
(syntax-parameterize ([bidi-match-going-in? #f])
|
||||
(match r [(number-arg a) a] [_ #f]))
|
||||
(match r [(number-arg a) a] [_ #f]))
|
||||
i)]))]
|
||||
(test-suite
|
||||
"bidi-match"
|
||||
(test "1" 1)
|
||||
(test "1.2" 1.2)
|
||||
(test "+inf.0" +inf.0)
|
||||
(test "a" #f)
|
||||
(test #f "a")))
|
||||
|
||||
(test-suite
|
||||
"bidi-match"
|
||||
(test "1" 1)
|
||||
(test "1.2" 1.2)
|
||||
(test "+inf.0" +inf.0)
|
||||
(test "a" #f)
|
||||
(test #f "a")))
|
||||
|
||||
(test-suite
|
||||
"http-expanders"
|
||||
|
||||
(test-not-false "http://www.example.com/new"
|
||||
|
||||
(test-not-false "http://www.example.com/new"
|
||||
(match (string->url "http://www.example.com/new")
|
||||
[(url/paths "new")
|
||||
#t]
|
||||
[else
|
||||
#f]))
|
||||
|
||||
(test-not-false "http://www.example.com/"
|
||||
|
||||
(test-not-false "http://www.example.com/"
|
||||
(match (string->url "http://www.example.com/")
|
||||
[(url/paths "")
|
||||
#t]
|
||||
[else
|
||||
#f]))
|
||||
|
||||
(test-not-false "http://www.example.com"
|
||||
|
||||
(test-not-false "http://www.example.com"
|
||||
(match (string->url "http://www.example.com")
|
||||
[(url/paths)
|
||||
#t]
|
||||
[else
|
||||
#f]))
|
||||
|
||||
(test-false "http://www.example.com/foo"
|
||||
|
||||
(test-false "http://www.example.com/foo"
|
||||
(match (string->url "http://www.example.com/foo")
|
||||
[(url/paths "new")
|
||||
#t]
|
||||
[else
|
||||
#f]))
|
||||
|
||||
|
||||
(test-equal? "http://www.example.com/new/50"
|
||||
(match (string->url "http://www.example.com/new/50")
|
||||
[(url/paths "new" (integer-arg a))
|
||||
|
|
@ -128,21 +128,21 @@
|
|||
[else
|
||||
#f])
|
||||
50)
|
||||
|
||||
|
||||
(test-false "http://www.example.com/new"
|
||||
(match (string->url "http://www.example.com/new")
|
||||
[(url/paths "new" (integer-arg a))
|
||||
a]
|
||||
[else
|
||||
#f]))
|
||||
|
||||
|
||||
(test-not-false "http://www.example.com/new"
|
||||
(match (test-request (string->url "http://www.example.com/new"))
|
||||
[(request/url (url/paths "new"))
|
||||
#t]
|
||||
[else
|
||||
#f]))
|
||||
|
||||
|
||||
(test-equal? "http://www.example.com/new/50"
|
||||
(match (test-request (string->url "http://www.example.com/new/50"))
|
||||
[(request/url (url/paths "new" (integer-arg a)))
|
||||
|
|
@ -150,14 +150,14 @@
|
|||
[else
|
||||
#f])
|
||||
50))
|
||||
|
||||
|
||||
(test-suite
|
||||
"pattern"
|
||||
|
||||
|
||||
(test-false "string-syntax?" (string-syntax? #'a))
|
||||
(test-false "string-syntax?" (string-syntax? #'(a b)))
|
||||
(test-not-false "string-syntax?" (string-syntax? #'"foo"))
|
||||
|
||||
|
||||
(test-equal? "dispatch-pattern-next-...?"
|
||||
(dispatch-pattern-next-...? #'(a))
|
||||
(list #f))
|
||||
|
|
@ -167,7 +167,7 @@
|
|||
(test-equal? "dispatch-pattern-next-...?"
|
||||
(dispatch-pattern-next-...? #'(a (... ...)))
|
||||
(list #t))
|
||||
|
||||
|
||||
(test-equal? "dispatch-pattern-not-..."
|
||||
(map syntax->datum (dispatch-pattern-not-... #'(a)))
|
||||
'(a))
|
||||
|
|
@ -177,23 +177,23 @@
|
|||
(test-equal? "dispatch-pattern-not-..."
|
||||
(map syntax->datum (dispatch-pattern-not-... #'(a (... ...))))
|
||||
'(a))
|
||||
|
||||
|
||||
(local
|
||||
[(define (test in out)
|
||||
(test-equal? "dispatch-pattern->dispatch-pattern/ids"
|
||||
(map syntax->datum (dispatch-pattern->dispatch-pattern/ids in))
|
||||
out))]
|
||||
(test-suite
|
||||
"dispatch-pattern->dispatch-pattern/ids"
|
||||
(test #'() empty)
|
||||
(test #'("string") (list "string"))
|
||||
(test #'((... ...)) (list '...))
|
||||
|
||||
(test-case "arg"
|
||||
(check-equal? (first (first (map syntax->datum (dispatch-pattern->dispatch-pattern/ids #'((string-arg))))))
|
||||
'string-arg)
|
||||
(check-pred symbol? (second (first (map syntax->datum (dispatch-pattern->dispatch-pattern/ids #'((string-arg))))))))))
|
||||
|
||||
[(define (test in out)
|
||||
(test-equal? "dispatch-pattern->dispatch-pattern/ids"
|
||||
(map syntax->datum (dispatch-pattern->dispatch-pattern/ids in))
|
||||
out))]
|
||||
(test-suite
|
||||
"dispatch-pattern->dispatch-pattern/ids"
|
||||
(test #'() empty)
|
||||
(test #'("string") (list "string"))
|
||||
(test #'((... ...)) (list '...))
|
||||
|
||||
(test-case "arg"
|
||||
(check-equal? (first (first (map syntax->datum (dispatch-pattern->dispatch-pattern/ids #'((string-arg))))))
|
||||
'string-arg)
|
||||
(check-pred symbol? (second (first (map syntax->datum (dispatch-pattern->dispatch-pattern/ids #'((string-arg))))))))))
|
||||
|
||||
(test-exn "dispatch-pattern? ..." exn? (lambda () (dispatch-pattern? #'((... ...)))))
|
||||
(test-exn "dispatch-pattern? foo ..." exn? (lambda () (dispatch-pattern? #'("foo" (... ...)))))
|
||||
(test-not-false "dispatch-pattern? integer-arg a ..." (dispatch-pattern? #'((integer-arg a) (... ...))))
|
||||
|
|
@ -202,7 +202,7 @@
|
|||
(test-not-false "dispatch-pattern?" (dispatch-pattern? #'((integer-arg) (... ...))))
|
||||
(test-not-false "dispatch-pattern?" (dispatch-pattern? #'((integer-arg))))
|
||||
(test-not-false "dispatch-pattern?" (dispatch-pattern? #'("foo")))
|
||||
|
||||
|
||||
(test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((... ...)))))
|
||||
(test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'("foo" (... ...)))))
|
||||
(test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'((integer-arg a) (... ...))))
|
||||
|
|
@ -210,8 +210,8 @@
|
|||
(test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'((list a b) (... ...))))
|
||||
(test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((integer-arg) (... ...)))))
|
||||
(test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((integer-arg)))))
|
||||
(test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'("foo"))))
|
||||
|
||||
(test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'("foo"))))
|
||||
|
||||
(local [(define-syntax test-arg
|
||||
(syntax-rules ()
|
||||
[(_ (arg arg-a ...)
|
||||
|
|
@ -221,71 +221,94 @@
|
|||
(test-suite (format "~S" 'arg)
|
||||
(test-equal? (format "in ~S" in-expr)
|
||||
(syntax-parameterize ([bidi-match-going-in? #t])
|
||||
(match in-expr [(arg arg-a ... a) a]))
|
||||
(match in-expr [(arg arg-a ... a) a]))
|
||||
out-expr)
|
||||
...
|
||||
(test-equal? (format "out ~S" out-expr)
|
||||
(syntax-parameterize ([bidi-match-going-in? #f])
|
||||
(match out-expr [(arg arg-a ... a) a]))
|
||||
(match out-expr [(arg arg-a ... a) a]))
|
||||
in-expr)
|
||||
...
|
||||
(test-false (format "in-fail ~S" in-fail-expr)
|
||||
(syntax-parameterize ([bidi-match-going-in? #t])
|
||||
(match in-fail-expr [(arg arg-a ... a) a] [_ #f])))
|
||||
(match in-fail-expr [(arg arg-a ... a) a] [_ #f])))
|
||||
...
|
||||
(test-false (format "out-fail ~S" out-fail-expr)
|
||||
(syntax-parameterize ([bidi-match-going-in? #f])
|
||||
(match out-fail-expr [(arg arg-a ... a) a] [_ #f])))
|
||||
(match out-fail-expr [(arg arg-a ... a) a] [_ #f])))
|
||||
...)]))]
|
||||
(test-suite
|
||||
"url-patterns"
|
||||
|
||||
(test-arg (number-arg)
|
||||
(["1" 1]
|
||||
["2.3" 2.3]
|
||||
["+inf.0" +inf.0])
|
||||
["a"]
|
||||
['a #t])
|
||||
|
||||
(test-arg (integer-arg)
|
||||
(["1" 1])
|
||||
["a" "2.3" "+inf.0"]
|
||||
['a #t 2.3 +inf.0])
|
||||
|
||||
(test-arg (real-arg)
|
||||
(["1" 1]
|
||||
["2.3" 2.3]
|
||||
["+inf.0" +inf.0])
|
||||
["a"]
|
||||
['a #t])
|
||||
|
||||
(test-arg (string-arg)
|
||||
(["1" "1"]
|
||||
["foo" "foo"]
|
||||
["/" "/"])
|
||||
[]
|
||||
['a #t 5])
|
||||
|
||||
(test-arg (symbol-arg)
|
||||
(["1" '|1|]
|
||||
["foo" 'foo]
|
||||
["/" '/])
|
||||
[]
|
||||
["a" #t 5])
|
||||
|
||||
(local [(define-match-expander const-m
|
||||
(syntax-rules ()
|
||||
[(_ v id) (? (curry equal? v) id)]))
|
||||
(define-bidi-match-expander const-arg const-m const-m)]
|
||||
(test-arg (const-arg "1")
|
||||
(["1" "1"])
|
||||
["2"]
|
||||
["2"]))))
|
||||
|
||||
(test-suite
|
||||
"url-patterns"
|
||||
|
||||
(test-arg (number-arg)
|
||||
(["1" 1]
|
||||
["2.3" 2.3]
|
||||
["+inf.0" +inf.0])
|
||||
["a"]
|
||||
['a #t])
|
||||
|
||||
(test-arg (integer-arg)
|
||||
(["1" 1])
|
||||
["a" "2.3" "+inf.0"]
|
||||
['a #t 2.3 +inf.0])
|
||||
|
||||
(test-arg (real-arg)
|
||||
(["1" 1]
|
||||
["2.3" 2.3]
|
||||
["+inf.0" +inf.0])
|
||||
["a"]
|
||||
['a #t])
|
||||
|
||||
(test-arg (string-arg)
|
||||
(["1" "1"]
|
||||
["foo" "foo"]
|
||||
["/" "/"])
|
||||
[]
|
||||
['a #t 5])
|
||||
|
||||
(test-arg (symbol-arg)
|
||||
(["1" '|1|]
|
||||
["foo" 'foo]
|
||||
["/" '/])
|
||||
[]
|
||||
["a" #t 5])
|
||||
|
||||
(local [(define-match-expander const-m
|
||||
(syntax-rules ()
|
||||
[(_ v id) (? (curry equal? v) id)]))
|
||||
(define-bidi-match-expander const-arg const-m const-m)]
|
||||
(test-arg (const-arg "1")
|
||||
(["1" "1"])
|
||||
["2"]
|
||||
["2"]))))
|
||||
|
||||
(test-suite
|
||||
"syntax"
|
||||
|
||||
(local
|
||||
|
||||
(test-suite
|
||||
"methods"
|
||||
(local
|
||||
[(define (get req i) (add1 i))
|
||||
(define (post req i) (sub1 i))
|
||||
(define-values (blog-dispatch blog-url blog-applies?)
|
||||
(dispatch-rules+applies
|
||||
[((integer-arg)) #:method "get" get]
|
||||
[((integer-arg)) #:method "post" post]
|
||||
[((integer-arg)) get]))
|
||||
(define (test-blog-dispatch url method val)
|
||||
(test-equal? url
|
||||
(blog-dispatch
|
||||
(test-request #:method method (string->url url)))
|
||||
val))]
|
||||
|
||||
(test-blog-dispatch "http://www.example.com/5" #"get" 6)
|
||||
(test-blog-dispatch "http://www.example.com/6" #"get" 7)
|
||||
(test-blog-dispatch "http://www.example.com/7" #"post" 6)
|
||||
(test-blog-dispatch "http://www.example.com/8" #"post" 7)))
|
||||
|
||||
(test-suite
|
||||
"applies"
|
||||
(local
|
||||
[(define (list-posts req) `(list-posts))
|
||||
(define (review-post req p) `(review-post ,p))
|
||||
(define (review-archive req y m) `(review-archive ,y ,m))
|
||||
|
|
@ -296,10 +319,10 @@
|
|||
[("posts" (string-arg)) review-post]
|
||||
[("archive" (integer-arg) (integer-arg)) review-archive]))
|
||||
(define (test-blog-dispatch url)
|
||||
(test-not-false url (blog-applies? (test-request (string->url url)))))
|
||||
(test-equal? url (blog-applies? (test-request (string->url url))) #t))
|
||||
(define (test-blog-dispatch/exn url)
|
||||
(test-false url (blog-applies? (test-request (string->url url)))))]
|
||||
|
||||
(test-equal? url (blog-applies? (test-request (string->url url))) #f))]
|
||||
|
||||
(test-blog-dispatch "http://www.example.com")
|
||||
(test-blog-dispatch "http://www.example.com/")
|
||||
(test-blog-dispatch "http://www.example.com/posts/hello-world")
|
||||
|
|
@ -307,13 +330,13 @@
|
|||
(test-blog-dispatch/exn "http://www.example.com/posts")
|
||||
(test-blog-dispatch/exn "http://www.example.com/archive/post/02")
|
||||
(test-blog-dispatch/exn "http://www.example.com/archive/2008/post")
|
||||
(test-blog-dispatch/exn "http://www.example.com/foo"))
|
||||
|
||||
(test-blog-dispatch/exn "http://www.example.com/foo")))
|
||||
|
||||
(let ()
|
||||
(define (list-posts req) `(list-posts))
|
||||
(define (review-post req p) `(review-post ,p))
|
||||
(define (review-archive req y m) `(review-archive ,y ,m))
|
||||
|
||||
|
||||
(define (make-dispatch-test-suite blog-dispatch blog-url)
|
||||
(define (test-blog-dispatch url res)
|
||||
(test-equal? url (blog-dispatch (test-request (string->url url))) res))
|
||||
|
|
@ -328,10 +351,10 @@
|
|||
(apply blog-url args))))
|
||||
(define (test-blog-dispatch/exn url)
|
||||
(test-exn url exn:dispatcher? (lambda () (blog-dispatch (test-request (string->url url))))))
|
||||
|
||||
|
||||
(test-suite
|
||||
"blog"
|
||||
|
||||
|
||||
(test-blog-dispatch "http://www.example.com" `(list-posts))
|
||||
(test-blog-dispatch "http://www.example.com/" `(list-posts))
|
||||
(test-blog-dispatch "http://www.example.com/posts/hello-world" `(review-post "hello-world"))
|
||||
|
|
@ -340,7 +363,7 @@
|
|||
(test-blog-dispatch/exn "http://www.example.com/archive/post/02")
|
||||
(test-blog-dispatch/exn "http://www.example.com/archive/2008/post")
|
||||
(test-blog-dispatch/exn "http://www.example.com/foo")
|
||||
|
||||
|
||||
(test-blog-url "/" list-posts)
|
||||
(test-blog-url "/posts/hello-world" review-post "hello-world")
|
||||
(test-blog-url "/archive/2008/2" review-archive 2008 02)
|
||||
|
|
@ -351,7 +374,7 @@
|
|||
(test-blog-url/exn review-archive 2008 02 1)
|
||||
(test-blog-url/exn review-archive "2008" 02)
|
||||
(test-blog-url/exn review-archive 2008 "02")))
|
||||
|
||||
|
||||
(test-suite
|
||||
"dispatch"
|
||||
(let ()
|
||||
|
|
@ -362,7 +385,7 @@
|
|||
[("posts" (string-arg)) review-post]
|
||||
[("archive" (integer-arg) (integer-arg)) review-archive]))
|
||||
(make-dispatch-test-suite blog-dispatch blog-url))
|
||||
|
||||
|
||||
(let ()
|
||||
(define-container blog-container
|
||||
(blog-dispatch blog-url))
|
||||
|
|
@ -375,87 +398,87 @@
|
|||
(dispatch-rules! blog-container
|
||||
[("archive" (integer-arg) (integer-arg)) review-archive])
|
||||
(make-dispatch-test-suite blog-dispatch blog-url))))
|
||||
|
||||
|
||||
(local
|
||||
[(define (sum req as) (apply + as))
|
||||
(define-values (rest-dispatch rest-url)
|
||||
(dispatch-rules
|
||||
[((integer-arg) ...) sum]))
|
||||
(define (test-rest-dispatch url res)
|
||||
(test-equal? url (rest-dispatch (test-request (string->url url))) res))
|
||||
(define (test-rest-url url . args)
|
||||
(test-equal? (format "~S" args)
|
||||
(apply rest-url args)
|
||||
url))
|
||||
(define (test-rest-url/exn . args)
|
||||
(test-exn (format "~S" args)
|
||||
exn?
|
||||
(lambda ()
|
||||
(apply rest-url args))))
|
||||
(define (test-rest-dispatch/exn url)
|
||||
(test-exn url exn:dispatcher? (lambda () (rest-dispatch (test-request (string->url url))))))]
|
||||
(test-suite
|
||||
"rest args"
|
||||
|
||||
(test-rest-dispatch "http://www.sum.com" 0)
|
||||
(test-rest-dispatch "http://www.sum.com/1" 1)
|
||||
(test-rest-dispatch "http://www.sum.com/1/2" 3)
|
||||
(test-rest-dispatch "http://www.sum.com/1/2/3" 6)
|
||||
(test-rest-dispatch/exn "http://www.sum.com/1/2/3/bar")
|
||||
(test-rest-dispatch/exn "http://www.sum.com/1/bar")
|
||||
(test-rest-dispatch/exn "http://www.sum.com/bar")
|
||||
|
||||
(test-rest-url "/" sum empty)
|
||||
(test-rest-url "/1" sum (list 1))
|
||||
(test-rest-url "/1/2" sum (list 1 2))
|
||||
(test-rest-url "/1/2/3" sum (list 1 2 3))
|
||||
(test-rest-url/exn sum "foo")
|
||||
(test-rest-url/exn sum 'bar)
|
||||
(test-rest-url/exn sum 1)
|
||||
(test-rest-url/exn sum #t)))
|
||||
|
||||
[(define (sum req as) (apply + as))
|
||||
(define-values (rest-dispatch rest-url)
|
||||
(dispatch-rules
|
||||
[((integer-arg) ...) sum]))
|
||||
(define (test-rest-dispatch url res)
|
||||
(test-equal? url (rest-dispatch (test-request (string->url url))) res))
|
||||
(define (test-rest-url url . args)
|
||||
(test-equal? (format "~S" args)
|
||||
(apply rest-url args)
|
||||
url))
|
||||
(define (test-rest-url/exn . args)
|
||||
(test-exn (format "~S" args)
|
||||
exn?
|
||||
(lambda ()
|
||||
(apply rest-url args))))
|
||||
(define (test-rest-dispatch/exn url)
|
||||
(test-exn url exn:dispatcher? (lambda () (rest-dispatch (test-request (string->url url))))))]
|
||||
(test-suite
|
||||
"rest args"
|
||||
|
||||
(test-rest-dispatch "http://www.sum.com" 0)
|
||||
(test-rest-dispatch "http://www.sum.com/1" 1)
|
||||
(test-rest-dispatch "http://www.sum.com/1/2" 3)
|
||||
(test-rest-dispatch "http://www.sum.com/1/2/3" 6)
|
||||
(test-rest-dispatch/exn "http://www.sum.com/1/2/3/bar")
|
||||
(test-rest-dispatch/exn "http://www.sum.com/1/bar")
|
||||
(test-rest-dispatch/exn "http://www.sum.com/bar")
|
||||
|
||||
(test-rest-url "/" sum empty)
|
||||
(test-rest-url "/1" sum (list 1))
|
||||
(test-rest-url "/1/2" sum (list 1 2))
|
||||
(test-rest-url "/1/2/3" sum (list 1 2 3))
|
||||
(test-rest-url/exn sum "foo")
|
||||
(test-rest-url/exn sum 'bar)
|
||||
(test-rest-url/exn sum 1)
|
||||
(test-rest-url/exn sum #t)))
|
||||
|
||||
(local
|
||||
[(define (sum req as ss) (list* (apply + as) ss))
|
||||
(define-values (rest-dispatch rest-url)
|
||||
(dispatch-rules
|
||||
[((integer-arg) ... (string-arg) ...) sum]))
|
||||
(define (test-rest-dispatch url res)
|
||||
(test-equal? url (rest-dispatch (test-request (string->url url))) res))
|
||||
(define (test-rest-url url . args)
|
||||
(test-equal? (format "~S" args)
|
||||
(apply rest-url args)
|
||||
url))
|
||||
(define (test-rest-url/exn . args)
|
||||
(test-exn (format "~S" args)
|
||||
exn?
|
||||
(lambda ()
|
||||
(apply rest-url args))))
|
||||
(define (test-rest-dispatch/exn url)
|
||||
(test-exn url exn:dispatcher? (lambda () (rest-dispatch (test-request (string->url url))))))]
|
||||
(test-suite
|
||||
"rest args (2)"
|
||||
|
||||
(test-rest-dispatch "http://www.sum.com" (list 0))
|
||||
(test-rest-dispatch "http://www.sum.com/1" (list 1))
|
||||
(test-rest-dispatch "http://www.sum.com/1/2" (list 3))
|
||||
(test-rest-dispatch "http://www.sum.com/1/2/3" (list 6))
|
||||
(test-rest-dispatch "http://www.sum.com/1/2/3/bar" (list 6 "bar"))
|
||||
(test-rest-dispatch "http://www.sum.com/1/bar" (list 1 "bar"))
|
||||
(test-rest-dispatch "http://www.sum.com/1/bar/zog" (list 1 "bar" "zog"))
|
||||
(test-rest-dispatch "http://www.sum.com/bar/zog" (list 0 "bar" "zog"))
|
||||
|
||||
(test-rest-url "/" sum empty empty)
|
||||
(test-rest-url "/1" sum (list 1) empty)
|
||||
(test-rest-url "/1/2" sum (list 1 2) empty)
|
||||
(test-rest-url "/1/2/3" sum (list 1 2 3) empty)
|
||||
(test-rest-url "/bar" sum empty (list "bar"))
|
||||
(test-rest-url "/bar/zog" sum empty (list "bar" "zog"))
|
||||
(test-rest-url "/1/2/bar" sum (list 1 2) (list "bar"))
|
||||
(test-rest-url/exn sum "foo")
|
||||
(test-rest-url/exn sum 'bar)
|
||||
(test-rest-url/exn sum 1)
|
||||
(test-rest-url/exn sum #t))))
|
||||
|
||||
[(define (sum req as ss) (list* (apply + as) ss))
|
||||
(define-values (rest-dispatch rest-url)
|
||||
(dispatch-rules
|
||||
[((integer-arg) ... (string-arg) ...) sum]))
|
||||
(define (test-rest-dispatch url res)
|
||||
(test-equal? url (rest-dispatch (test-request (string->url url))) res))
|
||||
(define (test-rest-url url . args)
|
||||
(test-equal? (format "~S" args)
|
||||
(apply rest-url args)
|
||||
url))
|
||||
(define (test-rest-url/exn . args)
|
||||
(test-exn (format "~S" args)
|
||||
exn?
|
||||
(lambda ()
|
||||
(apply rest-url args))))
|
||||
(define (test-rest-dispatch/exn url)
|
||||
(test-exn url exn:dispatcher? (lambda () (rest-dispatch (test-request (string->url url))))))]
|
||||
(test-suite
|
||||
"rest args (2)"
|
||||
|
||||
(test-rest-dispatch "http://www.sum.com" (list 0))
|
||||
(test-rest-dispatch "http://www.sum.com/1" (list 1))
|
||||
(test-rest-dispatch "http://www.sum.com/1/2" (list 3))
|
||||
(test-rest-dispatch "http://www.sum.com/1/2/3" (list 6))
|
||||
(test-rest-dispatch "http://www.sum.com/1/2/3/bar" (list 6 "bar"))
|
||||
(test-rest-dispatch "http://www.sum.com/1/bar" (list 1 "bar"))
|
||||
(test-rest-dispatch "http://www.sum.com/1/bar/zog" (list 1 "bar" "zog"))
|
||||
(test-rest-dispatch "http://www.sum.com/bar/zog" (list 0 "bar" "zog"))
|
||||
|
||||
(test-rest-url "/" sum empty empty)
|
||||
(test-rest-url "/1" sum (list 1) empty)
|
||||
(test-rest-url "/1/2" sum (list 1 2) empty)
|
||||
(test-rest-url "/1/2/3" sum (list 1 2 3) empty)
|
||||
(test-rest-url "/bar" sum empty (list "bar"))
|
||||
(test-rest-url "/bar/zog" sum empty (list "bar" "zog"))
|
||||
(test-rest-url "/1/2/bar" sum (list 1 2) (list "bar"))
|
||||
(test-rest-url/exn sum "foo")
|
||||
(test-rest-url/exn sum 'bar)
|
||||
(test-rest-url/exn sum 1)
|
||||
(test-rest-url/exn sum #t))))
|
||||
|
||||
(test-suite
|
||||
"serve")))
|
||||
|
||||
|
|
@ -474,5 +497,9 @@
|
|||
(define (display-sum req fst snd)
|
||||
`(html (head (title "Sum"))
|
||||
(h1 ,(number->string (+ fst snd)))))
|
||||
|
||||
|
||||
(serve/dispatch start))
|
||||
|
||||
(module+ main
|
||||
(require rackunit/text-ui)
|
||||
(run-tests all-dispatch-tests))
|
||||
|
|
|
|||
|
|
@ -15,11 +15,24 @@
|
|||
(url/path (app (lambda (ps) (map path/param-path ps))
|
||||
(list path-pat ...)))]))
|
||||
|
||||
(define (method-downcase x)
|
||||
(cond
|
||||
[(string? x)
|
||||
(string-downcase x)]
|
||||
[(bytes? x)
|
||||
(method-downcase (bytes->string/utf-8 x))]
|
||||
[else
|
||||
x]))
|
||||
|
||||
(define-match-expander request/url
|
||||
(syntax-rules ()
|
||||
[(_ url-pat)
|
||||
; req = method, url, headers, bindings, post-data, host-ip, host-port, client-ip
|
||||
(struct request (_ url-pat _ _ _ _ _ _))]))
|
||||
(request/url (or #f "get") url-pat)]
|
||||
[(_ method url-pat)
|
||||
; req = method, url, headers, bindings, post-data, host-ip, host-port, client-ip
|
||||
(struct request ((app method-downcase method)
|
||||
url-pat _ _ _ _ _ _))]))
|
||||
|
||||
(provide url/path
|
||||
url/paths
|
||||
|
|
|
|||
|
|
@ -7,60 +7,76 @@
|
|||
web-server/dispatch/http-expanders
|
||||
web-server/dispatch/bidi-match
|
||||
(for-syntax racket/base
|
||||
syntax/parse
|
||||
web-server/dispatch/pattern))
|
||||
|
||||
(define (default-else req)
|
||||
(next-dispatcher))
|
||||
|
||||
(begin-for-syntax
|
||||
(define default-method #'(or #f "get")))
|
||||
|
||||
(define (string-list->url strlist)
|
||||
(url->string
|
||||
(make-url #f #f #f #f #t
|
||||
(if (empty? strlist)
|
||||
(list (make-path/param "" empty))
|
||||
(map (lambda (s) (make-path/param s empty))
|
||||
strlist))
|
||||
(list (make-path/param "" empty))
|
||||
(map (lambda (s) (make-path/param s empty))
|
||||
strlist))
|
||||
empty #f)))
|
||||
|
||||
(define-syntax (dispatch-case stx)
|
||||
(syntax-case stx (else)
|
||||
[(_ [(path-pat ...) fun]
|
||||
...
|
||||
[else else-fun])
|
||||
(for-each dispatch-pattern?
|
||||
(syntax->list #'((path-pat ...) ...)))
|
||||
(with-syntax
|
||||
([((path-pat/id ...) ...)
|
||||
(map dispatch-pattern->dispatch-pattern/ids
|
||||
(syntax->list #'((path-pat ...) ...)))])
|
||||
(syntax-parse
|
||||
stx #:literals (else)
|
||||
[(_ [(path-pat ...)
|
||||
(~optional (~seq #:method method)
|
||||
#:defaults ([method default-method]))
|
||||
fun]
|
||||
...
|
||||
[else else-fun])
|
||||
#:fail-unless
|
||||
(for-each dispatch-pattern?
|
||||
(syntax->list #'((path-pat ...) ...)))
|
||||
"Not a dispatch pattern"
|
||||
(with-syntax
|
||||
([((path-pat-id ...) ...)
|
||||
(map (lambda (pp/is)
|
||||
(map (lambda (bs)
|
||||
(with-syntax ([(bidi-id arg ... id) bs])
|
||||
#'id))
|
||||
(filter (lambda (pp/i)
|
||||
(syntax-case pp/i ()
|
||||
[(bidi-id arg ... id) #t]
|
||||
[_ #f]))
|
||||
(syntax->list pp/is))))
|
||||
(syntax->list #'((path-pat/id ...) ...)))])
|
||||
(syntax/loc stx
|
||||
(lambda (the-req)
|
||||
(syntax-parameterize ([bidi-match-going-in? #t])
|
||||
(match the-req
|
||||
[(request/url (url/paths path-pat/id ...))
|
||||
(fun the-req path-pat-id ...)]
|
||||
...
|
||||
[_ (else-fun the-req)]))))))]
|
||||
[(dc [(path-pat ...) fun]
|
||||
...)
|
||||
(syntax/loc stx
|
||||
(dc [(path-pat ...) fun]
|
||||
...
|
||||
[else default-else]))]))
|
||||
([((path-pat/id ...) ...)
|
||||
(map dispatch-pattern->dispatch-pattern/ids
|
||||
(syntax->list #'((path-pat ...) ...)))])
|
||||
(with-syntax
|
||||
([((path-pat-id ...) ...)
|
||||
(map (lambda (pp/is)
|
||||
(map (lambda (bs)
|
||||
(with-syntax ([(bidi-id arg ... id) bs])
|
||||
#'id))
|
||||
(filter (lambda (pp/i)
|
||||
(syntax-case pp/i ()
|
||||
[(bidi-id arg ... id) #t]
|
||||
[_ #f]))
|
||||
(syntax->list pp/is))))
|
||||
(syntax->list #'((path-pat/id ...) ...)))])
|
||||
(syntax/loc stx
|
||||
(lambda (the-req)
|
||||
(syntax-parameterize ([bidi-match-going-in? #t])
|
||||
(match the-req
|
||||
[(request/url method (url/paths path-pat/id ...))
|
||||
(fun the-req path-pat-id ...)]
|
||||
...
|
||||
[_ (else-fun the-req)]))))))]
|
||||
[(dc [(path-pat ...)
|
||||
(~optional (~seq #:method method)
|
||||
#:defaults ([method default-method]))
|
||||
fun]
|
||||
...)
|
||||
(syntax/loc stx
|
||||
(dc [(path-pat ...)
|
||||
#:method method
|
||||
fun]
|
||||
...
|
||||
[else default-else]))]))
|
||||
|
||||
(define-syntax (dispatch-url stx)
|
||||
(syntax-case stx ()
|
||||
(syntax-parse
|
||||
stx
|
||||
[(_ [(path-pat ...) fun]
|
||||
...)
|
||||
(for-each dispatch-pattern?
|
||||
|
|
@ -78,69 +94,99 @@
|
|||
(with-syntax ([pp pp/i]
|
||||
[(bidi-id arg ... id) pp/i])
|
||||
(if next-...?
|
||||
(syntax/loc pp/i (list pp (... ...)))
|
||||
pp/i))))
|
||||
(syntax->list #'((path-pat/id ...) ...)))
|
||||
#;(map (lambda (pp/is)
|
||||
(filter (compose not string-syntax?)
|
||||
(syntax->list pp/is)))
|
||||
(syntax->list #'((path-pat/id ...) ...)))]
|
||||
(syntax/loc pp/i (list pp (... ...)))
|
||||
pp/i))))
|
||||
(syntax->list #'((path-pat/id ...) ...)))]
|
||||
[((from-body ...) ...)
|
||||
(map (lambda (pp/is)
|
||||
(for/list ([pp/i (dispatch-pattern-not-... pp/is)]
|
||||
[next-...? (dispatch-pattern-next-...? pp/is)])
|
||||
(with-syntax ([pp pp/i])
|
||||
(if (string-syntax? pp/i)
|
||||
(syntax/loc pp/i (list pp))
|
||||
(with-syntax ([(bidi-id arg ... id) pp/i])
|
||||
(if next-...?
|
||||
(syntax/loc pp/i id)
|
||||
(syntax/loc pp/i (list id))))))))
|
||||
(syntax/loc pp/i (list pp))
|
||||
(with-syntax ([(bidi-id arg ... id) pp/i])
|
||||
(if next-...?
|
||||
(syntax/loc pp/i id)
|
||||
(syntax/loc pp/i (list id))))))))
|
||||
(syntax->list #'((path-pat/id ...) ...)))])
|
||||
(syntax/loc stx
|
||||
(syntax-parameterize ([bidi-match-going-in? #f])
|
||||
(match-lambda*
|
||||
[(list (? (lambda (x) (eq? x fun))) from-path-pat ...)
|
||||
(string-list->url (append from-body ...))]
|
||||
...)))))]))
|
||||
(match-lambda*
|
||||
[(list (? (lambda (x) (eq? x fun))) from-path-pat ...)
|
||||
(string-list->url (append from-body ...))]
|
||||
...)))))]))
|
||||
|
||||
(define-syntax (dispatch-rules stx)
|
||||
(syntax-case stx (else)
|
||||
[(_ [(path-pat ...) fun]
|
||||
...
|
||||
[else else-fun])
|
||||
(for-each dispatch-pattern?
|
||||
(syntax->list #'((path-pat ...) ...)))
|
||||
(syntax/loc stx
|
||||
(values
|
||||
(dispatch-case [(path-pat ...) fun]
|
||||
...
|
||||
[else else-fun])
|
||||
(dispatch-url [(path-pat ...) fun]
|
||||
...)))]
|
||||
[(dr [(path-pat ...) fun]
|
||||
...)
|
||||
(syntax/loc stx
|
||||
(dr [(path-pat ...) fun]
|
||||
...
|
||||
[else default-else]))]))
|
||||
(syntax-parse
|
||||
stx #:literals (else)
|
||||
[(_ [(path-pat ...)
|
||||
(~optional (~seq #:method method)
|
||||
#:defaults ([method default-method]))
|
||||
fun]
|
||||
...
|
||||
[else else-fun])
|
||||
(for-each dispatch-pattern?
|
||||
(syntax->list #'((path-pat ...) ...)))
|
||||
(syntax/loc stx
|
||||
(values
|
||||
(dispatch-case [(path-pat ...)
|
||||
#:method method
|
||||
fun]
|
||||
...
|
||||
[else else-fun])
|
||||
(dispatch-url [(path-pat ...) fun]
|
||||
...)))]
|
||||
[(dr [(path-pat ...)
|
||||
(~optional (~seq #:method method)
|
||||
#:defaults ([method default-method]))
|
||||
fun]
|
||||
...)
|
||||
(syntax/loc stx
|
||||
(dr [(path-pat ...)
|
||||
#:method method
|
||||
fun]
|
||||
...
|
||||
[else default-else]))]))
|
||||
|
||||
(define (dispatch-succ . _) #t)
|
||||
(define (dispatch-fail . _) #f)
|
||||
|
||||
(define-syntax-rule (dispatch-rules+applies
|
||||
[pat fun]
|
||||
...)
|
||||
(let-values ([(dispatch url)
|
||||
(dispatch-rules
|
||||
[pat fun]
|
||||
...)]
|
||||
[(applies? _)
|
||||
(dispatch-rules
|
||||
[pat dispatch-succ]
|
||||
...
|
||||
[else dispatch-fail])])
|
||||
(values dispatch url applies?)))
|
||||
(define-syntax (dispatch-rules+applies stx)
|
||||
(syntax-parse
|
||||
stx #:literals (else)
|
||||
[(_
|
||||
[pat
|
||||
(~optional (~seq #:method method)
|
||||
#:defaults ([method default-method]))
|
||||
fun]
|
||||
...
|
||||
[else else-fun])
|
||||
(syntax/loc stx
|
||||
(let-values ([(dispatch url)
|
||||
(dispatch-rules
|
||||
[pat #:method method fun]
|
||||
...
|
||||
[else else-fun])]
|
||||
[(applies?)
|
||||
(λ (req) #t)])
|
||||
(values dispatch url applies?)))]
|
||||
[(_
|
||||
[pat
|
||||
(~optional (~seq #:method method)
|
||||
#:defaults ([method default-method]))
|
||||
fun]
|
||||
...)
|
||||
(syntax/loc stx
|
||||
(let-values ([(dispatch url)
|
||||
(dispatch-rules
|
||||
[pat #:method method fun]
|
||||
...)]
|
||||
[(applies?)
|
||||
(dispatch-case
|
||||
[pat #:method method dispatch-succ]
|
||||
...
|
||||
[else dispatch-fail])])
|
||||
(values dispatch url applies?)))]))
|
||||
|
||||
(provide dispatch-case
|
||||
dispatch-url
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
web-server/dispatchers/dispatch
|
||||
web-server/servlet-env
|
||||
web-server/dispatch/extend
|
||||
(except-in syntax/parse attribute)
|
||||
racket/match
|
||||
racket/list
|
||||
net/url
|
||||
|
|
@ -103,24 +104,37 @@ or else the filesystem server will never see the requests.
|
|||
|
||||
@section{API Reference}
|
||||
|
||||
@defform*[#:literals (else)
|
||||
@defform*[#:literals (else ~optional ~seq syntax or)
|
||||
[(dispatch-rules
|
||||
[dispatch-pattern dispatch-fun]
|
||||
[dispatch-pattern
|
||||
(~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
|
||||
dispatch-fun]
|
||||
...
|
||||
[else else-fun])
|
||||
(dispatch-rules
|
||||
[dispatch-pattern dispatch-fun]
|
||||
[dispatch-pattern
|
||||
(~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
|
||||
dispatch-fun]
|
||||
...)]
|
||||
#:contracts
|
||||
([else-fun (request? . -> . any)]
|
||||
[dispatch-fun (request? any/c ... . -> . any)])]{
|
||||
Returns two values: the first is a dispatching function with the contract @racket[(request? . -> . any)]
|
||||
that calls the appropriate @racket[dispatch-fun] based on the first @racket[dispatch-pattern] that matches the
|
||||
request's URL; the second is a URL-generating function with the contract @racket[(procedure? any/c ... . -> . string?)]
|
||||
that generates a URL using @racket[dispatch-pattern] for the @racket[dispatch-fun] given as its first argument.
|
||||
|
||||
If @racket[else-fun] is left out, one is provided that calls @racket[(next-dispatcher)] to signal to the Web Server that this
|
||||
dispatcher does not apply.
|
||||
|
||||
Returns two values: the first is a dispatching function with the
|
||||
contract @racket[(request? . -> . any)] that calls the appropriate
|
||||
@racket[dispatch-fun] based on the first @racket[dispatch-pattern]
|
||||
that matches the request's URL (and method), the second is a URL-generating
|
||||
function with the contract @racket[(procedure? any/c ... . ->
|
||||
. string?)] that generates a URL using @racket[dispatch-pattern] for
|
||||
the @racket[dispatch-fun] given as its first argument.
|
||||
|
||||
If @racket[else-fun] is left out, one is provided that calls
|
||||
@racket[(next-dispatcher)] to signal to the Web Server that this
|
||||
dispatcher does not apply.
|
||||
|
||||
If any @racket[_method] is left out, it assumed to apply to requests
|
||||
without methods and GET methods.
|
||||
|
||||
}
|
||||
|
||||
@racketgrammar[dispatch-pattern
|
||||
|
|
@ -129,13 +143,17 @@ or else the filesystem server will never see the requests.
|
|||
(bidi-match-expander ... . dispatch-pattern)
|
||||
(bidi-match-expander . dispatch-pattern)]
|
||||
|
||||
@defform*[#:literals (else)
|
||||
@defform*[#:literals (else ~optional ~seq syntax or)
|
||||
[(dispatch-rules+applies
|
||||
[dispatch-pattern dispatch-fun]
|
||||
[dispatch-pattern
|
||||
(~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
|
||||
dispatch-fun]
|
||||
...
|
||||
[else else-fun])
|
||||
(dispatch-rules+applies
|
||||
[dispatch-pattern dispatch-fun]
|
||||
[dispatch-pattern
|
||||
(~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
|
||||
dispatch-fun]
|
||||
...)]
|
||||
#:contracts
|
||||
([else-fun (request? . -> . any)]
|
||||
|
|
@ -144,13 +162,17 @@ or else the filesystem server will never see the requests.
|
|||
@racket[#t] if the dispatching rules apply to the request and @racket[#f] otherwise.
|
||||
}
|
||||
|
||||
@defform*[#:literals (else)
|
||||
@defform*[#:literals (else ~optional ~seq syntax or)
|
||||
[(dispatch-case
|
||||
[dispatch-pattern dispatch-fun]
|
||||
[dispatch-pattern
|
||||
(~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
|
||||
dispatch-fun]
|
||||
...
|
||||
[else else-fun])
|
||||
(dispatch-case
|
||||
[dispatch-pattern dispatch-fun]
|
||||
[dispatch-pattern
|
||||
(~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
|
||||
dispatch-fun]
|
||||
...)]
|
||||
#:contracts
|
||||
([else-fun (request? . -> . any)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user