From 211e869fe1e303d5d064075e4734c622eda2adf1 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 28 May 2012 14:13:19 -0600 Subject: [PATCH] Supporting methods in web-server/dispatch --- collects/tests/web-server/dispatch-test.rkt | 461 +++++++++--------- .../web-server/dispatch/http-expanders.rkt | 15 +- collects/web-server/dispatch/syntax.rkt | 220 +++++---- .../web-server/scribblings/dispatch.scrbl | 54 +- 4 files changed, 429 insertions(+), 321 deletions(-) diff --git a/collects/tests/web-server/dispatch-test.rkt b/collects/tests/web-server/dispatch-test.rkt index 8f3b9ac80c..c842a6a9ba 100644 --- a/collects/tests/web-server/dispatch-test.rkt +++ b/collects/tests/web-server/dispatch-test.rkt @@ -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)) diff --git a/collects/web-server/dispatch/http-expanders.rkt b/collects/web-server/dispatch/http-expanders.rkt index 7517d12d8e..8178d45e98 100644 --- a/collects/web-server/dispatch/http-expanders.rkt +++ b/collects/web-server/dispatch/http-expanders.rkt @@ -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 diff --git a/collects/web-server/dispatch/syntax.rkt b/collects/web-server/dispatch/syntax.rkt index 3d6d80c49b..7cedacc251 100644 --- a/collects/web-server/dispatch/syntax.rkt +++ b/collects/web-server/dispatch/syntax.rkt @@ -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 diff --git a/collects/web-server/scribblings/dispatch.scrbl b/collects/web-server/scribblings/dispatch.scrbl index 7ba03ebd73..18c8d16937 100644 --- a/collects/web-server/scribblings/dispatch.scrbl +++ b/collects/web-server/scribblings/dispatch.scrbl @@ -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)]