From 2a87df9e5c15e3320176cc758a006ad5c4b43842 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 2 Apr 2010 20:55:36 +0000 Subject: [PATCH] Supporting arguments in dispatch pattern arguments svn: r18724 --- collects/tests/web-server/dispatch-test.ss | 93 +++++++++++++------ collects/web-server/dispatch/bidi-match.ss | 6 +- collects/web-server/dispatch/pattern.ss | 12 +-- collects/web-server/dispatch/syntax.ss | 28 +++++- .../web-server/scribblings/dispatch.scrbl | 20 ++++ 5 files changed, 115 insertions(+), 44 deletions(-) diff --git a/collects/tests/web-server/dispatch-test.ss b/collects/tests/web-server/dispatch-test.ss index 96b7e28c2e..720f5ecb26 100644 --- a/collects/tests/web-server/dispatch-test.ss +++ b/collects/tests/web-server/dispatch-test.ss @@ -21,17 +21,17 @@ "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" @@ -193,11 +193,11 @@ '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?" exn? (lambda () (dispatch-pattern? #'("foo" (... ...))))) - (test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((integer-arg a) (... ...))))) - (test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((integer-arg a))))) - (test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((list a b) (... ...))))) + (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) (... ...)))) + (test-not-false "dispatch-pattern? integer-arg a " (dispatch-pattern? #'((integer-arg a)))) + (test-not-false "dispatch-pattern? list a b" (dispatch-pattern? #'((list a b) (... ...)))) (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"))) @@ -206,75 +206,108 @@ (test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'("foo" (... ...))))) (test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'((integer-arg a) (... ...)))) (test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'((integer-arg a)))) - (test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((list a b) (... ...))))) + (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")))) (local [(define-syntax test-arg (syntax-rules () - [(_ arg + [(_ (arg arg-a ...) ([in-expr out-expr] ...) [in-fail-expr ...] [out-fail-expr ...]) (test-suite (format "~S" 'arg) (test-equal? (format "in ~S" in-expr) (syntax-parameterize ([bidi-match-going-in? #t]) - (match in-expr [(arg 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 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 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 a) a] [_ #f]))) + (match out-fail-expr [(arg arg-a ... a) a] [_ #f]))) ...)]))] (test-suite "url-patterns" - (test-arg number-arg + (test-arg (number-arg) (["1" 1] ["2.3" 2.3] ["+inf.0" +inf.0]) ["a"] ['a #t]) - (test-arg integer-arg + (test-arg (integer-arg) (["1" 1]) ["a" "2.3" "+inf.0"] ['a #t 2.3 +inf.0]) - (test-arg real-arg + (test-arg (real-arg) (["1" 1] ["2.3" 2.3] ["+inf.0" +inf.0]) ["a"] ['a #t]) - (test-arg string-arg + (test-arg (string-arg) (["1" "1"] ["foo" "foo"] ["/" "/"]) [] ['a #t 5]) - (test-arg symbol-arg + (test-arg (symbol-arg) (["1" '|1|] ["foo" 'foo] ["/" '/]) [] - ["a" #t 5]))) + ["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 + [(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-values (blog-dispatch blog-url blog-applies?) + (dispatch-rules+applies + [("") list-posts] + [() list-posts] + [("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))))) + (define (test-blog-dispatch/exn url) + (test-false url (blog-applies? (test-request (string->url url)))))] + + (test-blog-dispatch "http://www.example.com") + (test-blog-dispatch "http://www.example.com/") + (test-blog-dispatch "http://www.example.com/posts/hello-world") + (test-blog-dispatch "http://www.example.com/archive/2008/02") + (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")) + (local [(define (list-posts req) `(list-posts)) (define (review-post req p) `(review-post ,p)) @@ -425,5 +458,5 @@ #;(test-serve/dispatch) -#;(require (planet schematics/schemeunit:3/text-ui)) -#;(run-tests all-dispatch-tests) +(require schemeunit/text-ui) +(run-tests all-dispatch-tests) diff --git a/collects/web-server/dispatch/bidi-match.ss b/collects/web-server/dispatch/bidi-match.ss index e0514d96d6..5e2a9b184f 100644 --- a/collects/web-server/dispatch/bidi-match.ss +++ b/collects/web-server/dispatch/bidi-match.ss @@ -10,10 +10,10 @@ (define-match-expander bidi-id (lambda (stx) (syntax-case stx () - [(_ id) + [(_ arg (... ...) id) (if (syntax-parameter-value #'bidi-match-going-in?) - (syntax/loc stx (in-expander id)) - (syntax/loc stx (out-expander id)))]))))])) + (syntax/loc stx (in-expander arg (... ...) id)) + (syntax/loc stx (out-expander arg (... ...) id)))]))))])) (provide bidi-match-going-in? define-bidi-match-expander) diff --git a/collects/web-server/dispatch/pattern.ss b/collects/web-server/dispatch/pattern.ss index 30e04a56ca..beb7243851 100644 --- a/collects/web-server/dispatch/pattern.ss +++ b/collects/web-server/dispatch/pattern.ss @@ -14,7 +14,7 @@ (define (dispatch/no-...? stx) (syntax-case stx () [() #t] - [((bidi) . rest-stx) + [((bidi arg ...) . rest-stx) (dispatch/...? #'rest-stx)] [(string . rest-stx) (string-syntax? #'string) @@ -22,7 +22,7 @@ (define (dispatch/...? stx) (syntax-case stx () [() #t] - [((bidi) . rest-stx) + [((bidi arg ...) . rest-stx) (dispatch/...? #'rest-stx)] [(string . rest-stx) (string-syntax? #'string) @@ -35,7 +35,7 @@ (define (dispatch/no-...? stx) (syntax-case stx () [() #t] - [((bidi id) . rest-stx) + [((bidi arg ... id) . rest-stx) (identifier? #'id) (dispatch/...? #'rest-stx)] [(string . rest-stx) @@ -44,7 +44,7 @@ (define (dispatch/...? stx) (syntax-case stx () [() #t] - [((bidi id) . rest-stx) + [((bidi arg ... id) . rest-stx) (identifier? #'id) (dispatch/...? #'rest-stx)] [(string . rest-stx) @@ -78,9 +78,9 @@ [(...? pp) pp] [else - (with-syntax ([(bidi-id) pp] + (with-syntax ([(bidi-id arg ...) pp] [id ppi]) - (syntax/loc pp (bidi-id id)))])) + (syntax/loc pp (bidi-id arg ... id)))])) (syntax->list pps) (generate-temporaries pps))) diff --git a/collects/web-server/dispatch/syntax.ss b/collects/web-server/dispatch/syntax.ss index 8069d87ce6..005bfc9972 100644 --- a/collects/web-server/dispatch/syntax.ss +++ b/collects/web-server/dispatch/syntax.ss @@ -33,11 +33,11 @@ ([((path-pat-id ...) ...) (map (lambda (pp/is) (map (lambda (bs) - (with-syntax ([(bidi-id id) bs]) + (with-syntax ([(bidi-id arg ... id) bs]) #'id)) (filter (lambda (pp/i) (syntax-case pp/i () - [(bidi-id id) #t] + [(bidi-id arg ... id) #t] [_ #f])) (syntax->list pp/is)))) (syntax->list #'((path-pat/id ...) ...)))]) @@ -73,7 +73,7 @@ (for/list ([pp/i (dispatch-pattern-not-... pp/is)] [next-...? (dispatch-pattern-next-...? pp/is)]) (with-syntax ([pp pp/i] - [(bidi-id id) pp/i]) + [(bidi-id arg ... id) pp/i]) (if next-...? (syntax/loc pp/i (list pp (... ...))) pp/i)))) @@ -89,7 +89,7 @@ (with-syntax ([pp pp/i]) (if (string-syntax? pp/i) (syntax/loc pp/i (list pp)) - (with-syntax ([(bidi-id id) pp/i]) + (with-syntax ([(bidi-id arg ... id) pp/i]) (if next-...? (syntax/loc pp/i id) (syntax/loc pp/i (list id)))))))) @@ -122,6 +122,24 @@ ... [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?))) + (provide dispatch-case dispatch-url - dispatch-rules) + dispatch-rules + dispatch-rules+applies) diff --git a/collects/web-server/scribblings/dispatch.scrbl b/collects/web-server/scribblings/dispatch.scrbl index ce8c8bd54c..ad3da5996f 100644 --- a/collects/web-server/scribblings/dispatch.scrbl +++ b/collects/web-server/scribblings/dispatch.scrbl @@ -80,6 +80,7 @@ After mastering the world of blogging software, you decide to put the ubiquitous (dispatch-rules [((integer-arg) ...) sum] [else (lambda (req) (sum req empty))])) + (define (sum req is) (apply + is)) @@ -121,6 +122,21 @@ After mastering the world of blogging software, you decide to put the ubiquitous (bidi-match-expander ... . dispatch-pattern) (bidi-match-expander . dispatch-pattern)] +@defform*[#:literals (else) + [(dispatch-rules+applies + [dispatch-pattern dispatch-fun] + ... + [else else-fun]) + (dispatch-rules+applies + [dispatch-pattern dispatch-fun] + ...)] + #:contracts + ([else-fun (request? . -> . response/c)] + [dispatch-fun (request? any/c ... . -> . response/c)])]{ + Like @scheme[dispatch-rules], except returns a third value with the contract @scheme[(request? . -> . boolean?)] that returns + @scheme[#t] if the dispatching rules apply to the request and @scheme[#f] otherwise. + } + @defform*[#:literals (else) [(dispatch-case [dispatch-pattern dispatch-fun] @@ -183,6 +199,10 @@ You can create new URL component patterns by defining @tech{bi-directional match Binds @scheme[id] to a @deftech{bi-directional match expander} where @scheme[in-xform] is a match expander (defined by @scheme[define-match-expander]) that is used when parsing URLs and @scheme[out-xform] is one used when generating URLs. + + Both @scheme[in-xform] and @scheme[out-xform] should use the syntax @scheme[(_xform arg ... _id)] where the @scheme[arg]s are + specific to @scheme[id] and compatible with both @scheme[in-xform] and @scheme[out-xform]. @scheme[_id] will typically be provided + automatically by @scheme[dispatch-rules]. } @defidform[bidi-match-going-in?]{