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

Supporting methods in web-server/dispatch

Browse Source
This commit is contained in:
Jay McCarthy 2012-05-28 14:13:19 -06:00
parent 8b035f3c73
commit 211e869fe1
4 changed files with 429 additions and 321 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

351
collects/tests/web-server/dispatch-test.rkt
View File

@ -14,35 +14,35 @@
web-server/dispatch/container) web-server/dispatch/container)
(provide all-dispatch-tests) (provide all-dispatch-tests)
(define (test-request url) (define (test-request url #:method [method #"GET"])
(make-request #"GET" url null (delay null) #f "1.2.3.4" 123 "4.3.2.1")) (make-request method url null (delay null) #f "1.2.3.4" 123 "4.3.2.1"))
(define all-dispatch-tests (define all-dispatch-tests
(test-suite (test-suite
"Dispatch" "Dispatch"
#;(local #;(local
[(define-syntax test-match=> [(define-syntax test-match=>
(syntax-rules () (syntax-rules ()
[(_ val pat res) [(_ val pat res)
(test-equal? (format "~S" 'pat) (test-equal? (format "~S" 'pat)
(match=> val [pat => (lambda x x)]) (match=> val [pat => (lambda x x)])
res)]))] res)]))]
(test-suite (test-suite
"match" "match"
(test-match=> (list 1 2) (list a b) (list 1 2)) (test-match=> (list 1 2) (list a b) (list 1 2))
(test-match=> (list 1 2) (list _ b) (list 2)))) (test-match=> (list 1 2) (list _ b) (list 2))))
(test-suite (test-suite
"coercion" "coercion"
(test-suite "make-coerce-safe?" (test-suite "make-coerce-safe?"
(local [(define string->number? (make-coerce-safe? string->number))] (local [(define string->number? (make-coerce-safe? string->number))]
(test-not-false "1" (string->number? "1")) (test-not-false "1" (string->number? "1"))
(test-not-false "1.2" (string->number? "1.2")) (test-not-false "1.2" (string->number? "1.2"))
(test-not-false "+inf.0" (string->number? "+inf.0")) (test-not-false "+inf.0" (string->number? "+inf.0"))
(test-false "a" (string->number? "a")))) (test-false "a" (string->number? "a"))))
(test-suite "define-coercion-match-expander" (test-suite "define-coercion-match-expander"
@ -50,10 +50,10 @@
(define-coercion-match-expander string->number/m string->number? string->number) (define-coercion-match-expander string->number/m string->number? string->number)
(define (test i r) (define (test i r)
(test-equal? i (match i [(string->number/m a) a] [_ #f]) r))] (test-equal? i (match i [(string->number/m a) a] [_ #f]) r))]
(test "1" 1) (test "1" 1)
(test "1.2" 1.2) (test "1.2" 1.2)
(test "+inf.0" +inf.0) (test "+inf.0" +inf.0)
(test "a" #f)))) (test "a" #f))))
(local [(define string->number? (make-coerce-safe? string->number)) (local [(define string->number? (make-coerce-safe? string->number))
(define-coercion-match-expander string->number/m string->number? string->number) (define-coercion-match-expander string->number/m string->number? string->number)
@ -65,30 +65,30 @@
(test-suite (format "~S" (list i r)) (test-suite (format "~S" (list i r))
(test-equal? (format "~S" i) (test-equal? (format "~S" i)
(syntax-parameterize ([bidi-match-going-in? #t]) (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) (test-equal? (format "~S" r)
(syntax-parameterize ([bidi-match-going-in? #f]) (syntax-parameterize ([bidi-match-going-in? #f])
(match r [(number-arg a) a] [_ #f])) (match r [(number-arg a) a] [_ #f]))
i))] i))]
[i [i
(test-equal? (format "~S" i) (test-equal? (format "~S" i)
(syntax-parameterize ([bidi-match-going-in? #t]) (syntax-parameterize ([bidi-match-going-in? #t])
(match i [(number-arg a) a] [_ #f])) (match i [(number-arg a) a] [_ #f]))
r)] r)]
[r [r
(test-equal? (format "~S" r) (test-equal? (format "~S" r)
(syntax-parameterize ([bidi-match-going-in? #f]) (syntax-parameterize ([bidi-match-going-in? #f])
(match r [(number-arg a) a] [_ #f])) (match r [(number-arg a) a] [_ #f]))
i)]))] i)]))]
(test-suite (test-suite
"bidi-match" "bidi-match"
(test "1" 1) (test "1" 1)
(test "1.2" 1.2) (test "1.2" 1.2)
(test "+inf.0" +inf.0) (test "+inf.0" +inf.0)
(test "a" #f) (test "a" #f)
(test #f "a"))) (test #f "a")))
(test-suite (test-suite
"http-expanders" "http-expanders"
@ -179,20 +179,20 @@
'(a)) '(a))
(local (local
[(define (test in out) [(define (test in out)
(test-equal? "dispatch-pattern->dispatch-pattern/ids" (test-equal? "dispatch-pattern->dispatch-pattern/ids"
(map syntax->datum (dispatch-pattern->dispatch-pattern/ids in)) (map syntax->datum (dispatch-pattern->dispatch-pattern/ids in))
out))] out))]
(test-suite (test-suite
"dispatch-pattern->dispatch-pattern/ids" "dispatch-pattern->dispatch-pattern/ids"
(test #'() empty) (test #'() empty)
(test #'("string") (list "string")) (test #'("string") (list "string"))
(test #'((... ...)) (list '...)) (test #'((... ...)) (list '...))
(test-case "arg" (test-case "arg"
(check-equal? (first (first (map syntax->datum (dispatch-pattern->dispatch-pattern/ids #'((string-arg)))))) (check-equal? (first (first (map syntax->datum (dispatch-pattern->dispatch-pattern/ids #'((string-arg))))))
'string-arg) 'string-arg)
(check-pred symbol? (second (first (map syntax->datum (dispatch-pattern->dispatch-pattern/ids #'((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? #'((... ...)))))
(test-exn "dispatch-pattern? foo ..." exn? (lambda () (dispatch-pattern? #'("foo" (... ...))))) (test-exn "dispatch-pattern? foo ..." exn? (lambda () (dispatch-pattern? #'("foo" (... ...)))))
@ -221,71 +221,94 @@
(test-suite (format "~S" 'arg) (test-suite (format "~S" 'arg)
(test-equal? (format "in ~S" in-expr) (test-equal? (format "in ~S" in-expr)
(syntax-parameterize ([bidi-match-going-in? #t]) (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) out-expr)
... ...
(test-equal? (format "out ~S" out-expr) (test-equal? (format "out ~S" out-expr)
(syntax-parameterize ([bidi-match-going-in? #f]) (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) in-expr)
... ...
(test-false (format "in-fail ~S" in-fail-expr) (test-false (format "in-fail ~S" in-fail-expr)
(syntax-parameterize ([bidi-match-going-in? #t]) (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) (test-false (format "out-fail ~S" out-fail-expr)
(syntax-parameterize ([bidi-match-going-in? #f]) (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 (test-suite
"url-patterns" "url-patterns"
(test-arg (number-arg) (test-arg (number-arg)
(["1" 1] (["1" 1]
["2.3" 2.3] ["2.3" 2.3]
["+inf.0" +inf.0]) ["+inf.0" +inf.0])
["a"] ["a"]
['a #t]) ['a #t])
(test-arg (integer-arg) (test-arg (integer-arg)
(["1" 1]) (["1" 1])
["a" "2.3" "+inf.0"] ["a" "2.3" "+inf.0"]
['a #t 2.3 +inf.0]) ['a #t 2.3 +inf.0])
(test-arg (real-arg) (test-arg (real-arg)
(["1" 1] (["1" 1]
["2.3" 2.3] ["2.3" 2.3]
["+inf.0" +inf.0]) ["+inf.0" +inf.0])
["a"] ["a"]
['a #t]) ['a #t])
(test-arg (string-arg) (test-arg (string-arg)
(["1" "1"] (["1" "1"]
["foo" "foo"] ["foo" "foo"]
["/" "/"]) ["/" "/"])
[] []
['a #t 5]) ['a #t 5])
(test-arg (symbol-arg) (test-arg (symbol-arg)
(["1" '|1|] (["1" '|1|]
["foo" 'foo] ["foo" 'foo]
["/" '/]) ["/" '/])
[] []
["a" #t 5]) ["a" #t 5])
(local [(define-match-expander const-m (local [(define-match-expander const-m
(syntax-rules () (syntax-rules ()
[(_ v id) (? (curry equal? v) id)])) [(_ v id) (? (curry equal? v) id)]))
(define-bidi-match-expander const-arg const-m const-m)] (define-bidi-match-expander const-arg const-m const-m)]
(test-arg (const-arg "1") (test-arg (const-arg "1")
(["1" "1"]) (["1" "1"])
["2"] ["2"]
["2"])))) ["2"]))))
(test-suite (test-suite
"syntax" "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 (list-posts req) `(list-posts))
(define (review-post req p) `(review-post ,p)) (define (review-post req p) `(review-post ,p))
(define (review-archive req y m) `(review-archive ,y ,m)) (define (review-archive req y m) `(review-archive ,y ,m))
@ -296,9 +319,9 @@
[("posts" (string-arg)) review-post] [("posts" (string-arg)) review-post]
[("archive" (integer-arg) (integer-arg)) review-archive])) [("archive" (integer-arg) (integer-arg)) review-archive]))
(define (test-blog-dispatch url) (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) (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/") (test-blog-dispatch "http://www.example.com/")
@ -307,7 +330,7 @@
(test-blog-dispatch/exn "http://www.example.com/posts") (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/post/02")
(test-blog-dispatch/exn "http://www.example.com/archive/2008/post") (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 () (let ()
(define (list-posts req) `(list-posts)) (define (list-posts req) `(list-posts))
@ -377,84 +400,84 @@
(make-dispatch-test-suite blog-dispatch blog-url)))) (make-dispatch-test-suite blog-dispatch blog-url))))
(local (local
[(define (sum req as) (apply + as)) [(define (sum req as) (apply + as))
(define-values (rest-dispatch rest-url) (define-values (rest-dispatch rest-url)
(dispatch-rules (dispatch-rules
[((integer-arg) ...) sum])) [((integer-arg) ...) sum]))
(define (test-rest-dispatch url res) (define (test-rest-dispatch url res)
(test-equal? url (rest-dispatch (test-request (string->url url))) res)) (test-equal? url (rest-dispatch (test-request (string->url url))) res))
(define (test-rest-url url . args) (define (test-rest-url url . args)
(test-equal? (format "~S" args) (test-equal? (format "~S" args)
(apply rest-url args) (apply rest-url args)
url)) url))
(define (test-rest-url/exn . args) (define (test-rest-url/exn . args)
(test-exn (format "~S" args) (test-exn (format "~S" args)
exn? exn?
(lambda () (lambda ()
(apply rest-url args)))) (apply rest-url args))))
(define (test-rest-dispatch/exn url) (define (test-rest-dispatch/exn url)
(test-exn url exn:dispatcher? (lambda () (rest-dispatch (test-request (string->url url))))))] (test-exn url exn:dispatcher? (lambda () (rest-dispatch (test-request (string->url url))))))]
(test-suite (test-suite
"rest args" "rest args"
(test-rest-dispatch "http://www.sum.com" 0) (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" 1)
(test-rest-dispatch "http://www.sum.com/1/2" 3) (test-rest-dispatch "http://www.sum.com/1/2" 3)
(test-rest-dispatch "http://www.sum.com/1/2/3" 6) (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/2/3/bar")
(test-rest-dispatch/exn "http://www.sum.com/1/bar") (test-rest-dispatch/exn "http://www.sum.com/1/bar")
(test-rest-dispatch/exn "http://www.sum.com/bar") (test-rest-dispatch/exn "http://www.sum.com/bar")
(test-rest-url "/" sum empty) (test-rest-url "/" sum empty)
(test-rest-url "/1" sum (list 1)) (test-rest-url "/1" sum (list 1))
(test-rest-url "/1/2" sum (list 1 2)) (test-rest-url "/1/2" sum (list 1 2))
(test-rest-url "/1/2/3" sum (list 1 2 3)) (test-rest-url "/1/2/3" sum (list 1 2 3))
(test-rest-url/exn sum "foo") (test-rest-url/exn sum "foo")
(test-rest-url/exn sum 'bar) (test-rest-url/exn sum 'bar)
(test-rest-url/exn sum 1) (test-rest-url/exn sum 1)
(test-rest-url/exn sum #t))) (test-rest-url/exn sum #t)))
(local (local
[(define (sum req as ss) (list* (apply + as) ss)) [(define (sum req as ss) (list* (apply + as) ss))
(define-values (rest-dispatch rest-url) (define-values (rest-dispatch rest-url)
(dispatch-rules (dispatch-rules
[((integer-arg) ... (string-arg) ...) sum])) [((integer-arg) ... (string-arg) ...) sum]))
(define (test-rest-dispatch url res) (define (test-rest-dispatch url res)
(test-equal? url (rest-dispatch (test-request (string->url url))) res)) (test-equal? url (rest-dispatch (test-request (string->url url))) res))
(define (test-rest-url url . args) (define (test-rest-url url . args)
(test-equal? (format "~S" args) (test-equal? (format "~S" args)
(apply rest-url args) (apply rest-url args)
url)) url))
(define (test-rest-url/exn . args) (define (test-rest-url/exn . args)
(test-exn (format "~S" args) (test-exn (format "~S" args)
exn? exn?
(lambda () (lambda ()
(apply rest-url args)))) (apply rest-url args))))
(define (test-rest-dispatch/exn url) (define (test-rest-dispatch/exn url)
(test-exn url exn:dispatcher? (lambda () (rest-dispatch (test-request (string->url url))))))] (test-exn url exn:dispatcher? (lambda () (rest-dispatch (test-request (string->url url))))))]
(test-suite (test-suite
"rest args (2)" "rest args (2)"
(test-rest-dispatch "http://www.sum.com" (list 0)) (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" (list 1))
(test-rest-dispatch "http://www.sum.com/1/2" (list 3)) (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" (list 6))
(test-rest-dispatch "http://www.sum.com/1/2/3/bar" (list 6 "bar")) (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" (list 1 "bar"))
(test-rest-dispatch "http://www.sum.com/1/bar/zog" (list 1 "bar" "zog")) (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-dispatch "http://www.sum.com/bar/zog" (list 0 "bar" "zog"))
(test-rest-url "/" sum empty empty) (test-rest-url "/" sum empty empty)
(test-rest-url "/1" sum (list 1) empty) (test-rest-url "/1" sum (list 1) empty)
(test-rest-url "/1/2" sum (list 1 2) 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 "/1/2/3" sum (list 1 2 3) empty)
(test-rest-url "/bar" sum empty (list "bar")) (test-rest-url "/bar" sum empty (list "bar"))
(test-rest-url "/bar/zog" sum empty (list "bar" "zog")) (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 "/1/2/bar" sum (list 1 2) (list "bar"))
(test-rest-url/exn sum "foo") (test-rest-url/exn sum "foo")
(test-rest-url/exn sum 'bar) (test-rest-url/exn sum 'bar)
(test-rest-url/exn sum 1) (test-rest-url/exn sum 1)
(test-rest-url/exn sum #t)))) (test-rest-url/exn sum #t))))
(test-suite (test-suite
"serve"))) "serve")))
@ -476,3 +499,7 @@
(h1 ,(number->string (+ fst snd))))) (h1 ,(number->string (+ fst snd)))))
(serve/dispatch start)) (serve/dispatch start))
(module+ main
(require rackunit/text-ui)
(run-tests all-dispatch-tests))

15
collects/web-server/dispatch/http-expanders.rkt
View File

@ -15,11 +15,24 @@
(url/path (app (lambda (ps) (map path/param-path ps)) (url/path (app (lambda (ps) (map path/param-path ps))
(list path-pat ...)))])) (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 (define-match-expander request/url
(syntax-rules () (syntax-rules ()
[(_ url-pat) [(_ url-pat)
; req = method, url, headers, bindings, post-data, host-ip, host-port, client-ip ; 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 (provide url/path
url/paths url/paths

220
collects/web-server/dispatch/syntax.rkt
View File

@ -7,60 +7,76 @@
web-server/dispatch/http-expanders web-server/dispatch/http-expanders
web-server/dispatch/bidi-match web-server/dispatch/bidi-match
(for-syntax racket/base (for-syntax racket/base
syntax/parse
web-server/dispatch/pattern)) web-server/dispatch/pattern))
(define (default-else req) (define (default-else req)
(next-dispatcher)) (next-dispatcher))
(begin-for-syntax
(define default-method #'(or #f "get")))
(define (string-list->url strlist) (define (string-list->url strlist)
(url->string (url->string
(make-url #f #f #f #f #t (make-url #f #f #f #f #t
(if (empty? strlist) (if (empty? strlist)
(list (make-path/param "" empty)) (list (make-path/param "" empty))
(map (lambda (s) (make-path/param s empty)) (map (lambda (s) (make-path/param s empty))
strlist)) strlist))
empty #f))) empty #f)))
(define-syntax (dispatch-case stx) (define-syntax (dispatch-case stx)
(syntax-case stx (else) (syntax-parse
[(_ [(path-pat ...) fun] stx #:literals (else)
... [(_ [(path-pat ...)
[else else-fun]) (~optional (~seq #:method method)
(for-each dispatch-pattern? #:defaults ([method default-method]))
(syntax->list #'((path-pat ...) ...))) fun]
(with-syntax ...
([((path-pat/id ...) ...) [else else-fun])
(map dispatch-pattern->dispatch-pattern/ids #:fail-unless
(syntax->list #'((path-pat ...) ...)))]) (for-each dispatch-pattern?
(syntax->list #'((path-pat ...) ...)))
"Not a dispatch pattern"
(with-syntax (with-syntax
([((path-pat-id ...) ...) ([((path-pat/id ...) ...)
(map (lambda (pp/is) (map dispatch-pattern->dispatch-pattern/ids
(map (lambda (bs) (syntax->list #'((path-pat ...) ...)))])
(with-syntax ([(bidi-id arg ... id) bs]) (with-syntax
#'id)) ([((path-pat-id ...) ...)
(filter (lambda (pp/i) (map (lambda (pp/is)
(syntax-case pp/i () (map (lambda (bs)
[(bidi-id arg ... id) #t] (with-syntax ([(bidi-id arg ... id) bs])
[_ #f])) #'id))
(syntax->list pp/is)))) (filter (lambda (pp/i)
(syntax->list #'((path-pat/id ...) ...)))]) (syntax-case pp/i ()
(syntax/loc stx [(bidi-id arg ... id) #t]
(lambda (the-req) [_ #f]))
(syntax-parameterize ([bidi-match-going-in? #t]) (syntax->list pp/is))))
(match the-req (syntax->list #'((path-pat/id ...) ...)))])
[(request/url (url/paths path-pat/id ...)) (syntax/loc stx
(fun the-req path-pat-id ...)] (lambda (the-req)
... (syntax-parameterize ([bidi-match-going-in? #t])
[_ (else-fun the-req)]))))))] (match the-req
[(dc [(path-pat ...) fun] [(request/url method (url/paths path-pat/id ...))
...) (fun the-req path-pat-id ...)]
(syntax/loc stx ...
(dc [(path-pat ...) fun] [_ (else-fun the-req)]))))))]
... [(dc [(path-pat ...)
[else default-else]))])) (~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) (define-syntax (dispatch-url stx)
(syntax-case stx () (syntax-parse
stx
[(_ [(path-pat ...) fun] [(_ [(path-pat ...) fun]
...) ...)
(for-each dispatch-pattern? (for-each dispatch-pattern?
@ -78,69 +94,99 @@
(with-syntax ([pp pp/i] (with-syntax ([pp pp/i]
[(bidi-id arg ... id) pp/i]) [(bidi-id arg ... id) pp/i])
(if next-...? (if next-...?
(syntax/loc pp/i (list pp (... ...))) (syntax/loc pp/i (list pp (... ...)))
pp/i)))) pp/i))))
(syntax->list #'((path-pat/id ...) ...))) (syntax->list #'((path-pat/id ...) ...)))]
#;(map (lambda (pp/is)
(filter (compose not string-syntax?)
(syntax->list pp/is)))
(syntax->list #'((path-pat/id ...) ...)))]
[((from-body ...) ...) [((from-body ...) ...)
(map (lambda (pp/is) (map (lambda (pp/is)
(for/list ([pp/i (dispatch-pattern-not-... pp/is)] (for/list ([pp/i (dispatch-pattern-not-... pp/is)]
[next-...? (dispatch-pattern-next-...? pp/is)]) [next-...? (dispatch-pattern-next-...? pp/is)])
(with-syntax ([pp pp/i]) (with-syntax ([pp pp/i])
(if (string-syntax? pp/i) (if (string-syntax? pp/i)
(syntax/loc pp/i (list pp)) (syntax/loc pp/i (list pp))
(with-syntax ([(bidi-id arg ... id) pp/i]) (with-syntax ([(bidi-id arg ... id) pp/i])
(if next-...? (if next-...?
(syntax/loc pp/i id) (syntax/loc pp/i id)
(syntax/loc pp/i (list id)))))))) (syntax/loc pp/i (list id))))))))
(syntax->list #'((path-pat/id ...) ...)))]) (syntax->list #'((path-pat/id ...) ...)))])
(syntax/loc stx (syntax/loc stx
(syntax-parameterize ([bidi-match-going-in? #f]) (syntax-parameterize ([bidi-match-going-in? #f])
(match-lambda* (match-lambda*
[(list (? (lambda (x) (eq? x fun))) from-path-pat ...) [(list (? (lambda (x) (eq? x fun))) from-path-pat ...)
(string-list->url (append from-body ...))] (string-list->url (append from-body ...))]
...)))))])) ...)))))]))
(define-syntax (dispatch-rules stx) (define-syntax (dispatch-rules stx)
(syntax-case stx (else) (syntax-parse
[(_ [(path-pat ...) fun] stx #:literals (else)
... [(_ [(path-pat ...)
[else else-fun]) (~optional (~seq #:method method)
(for-each dispatch-pattern? #:defaults ([method default-method]))
(syntax->list #'((path-pat ...) ...))) fun]
(syntax/loc stx ...
(values [else else-fun])
(dispatch-case [(path-pat ...) fun] (for-each dispatch-pattern?
... (syntax->list #'((path-pat ...) ...)))
[else else-fun]) (syntax/loc stx
(dispatch-url [(path-pat ...) fun] (values
...)))] (dispatch-case [(path-pat ...)
[(dr [(path-pat ...) fun] #:method method
...) fun]
(syntax/loc stx ...
(dr [(path-pat ...) fun] [else else-fun])
... (dispatch-url [(path-pat ...) fun]
[else default-else]))])) ...)))]
[(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-succ . _) #t)
(define (dispatch-fail . _) #f) (define (dispatch-fail . _) #f)
(define-syntax-rule (dispatch-rules+applies (define-syntax (dispatch-rules+applies stx)
[pat fun] (syntax-parse
...) stx #:literals (else)
(let-values ([(dispatch url) [(_
(dispatch-rules [pat
[pat fun] (~optional (~seq #:method method)
...)] #:defaults ([method default-method]))
[(applies? _) fun]
(dispatch-rules ...
[pat dispatch-succ] [else else-fun])
... (syntax/loc stx
[else dispatch-fail])]) (let-values ([(dispatch url)
(values dispatch url applies?))) (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 (provide dispatch-case
dispatch-url dispatch-url

52
collects/web-server/scribblings/dispatch.scrbl
View File

@ -5,6 +5,7 @@
web-server/dispatchers/dispatch web-server/dispatchers/dispatch
web-server/servlet-env web-server/servlet-env
web-server/dispatch/extend web-server/dispatch/extend
(except-in syntax/parse attribute)
racket/match racket/match
racket/list racket/list
net/url net/url
@ -103,24 +104,37 @@ or else the filesystem server will never see the requests.
@section{API Reference} @section{API Reference}
@defform*[#:literals (else) @defform*[#:literals (else ~optional ~seq syntax or)
[(dispatch-rules [(dispatch-rules
[dispatch-pattern dispatch-fun] [dispatch-pattern
(~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
dispatch-fun]
... ...
[else else-fun]) [else else-fun])
(dispatch-rules (dispatch-rules
[dispatch-pattern dispatch-fun] [dispatch-pattern
(~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
dispatch-fun]
...)] ...)]
#:contracts #:contracts
([else-fun (request? . -> . any)] ([else-fun (request? . -> . any)]
[dispatch-fun (request? any/c ... . -> . 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 Returns two values: the first is a dispatching function with the
dispatcher does not apply. 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 @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)
(bidi-match-expander . dispatch-pattern)] (bidi-match-expander . dispatch-pattern)]
@defform*[#:literals (else) @defform*[#:literals (else ~optional ~seq syntax or)
[(dispatch-rules+applies [(dispatch-rules+applies
[dispatch-pattern dispatch-fun] [dispatch-pattern
(~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
dispatch-fun]
... ...
[else else-fun]) [else else-fun])
(dispatch-rules+applies (dispatch-rules+applies
[dispatch-pattern dispatch-fun] [dispatch-pattern
(~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
dispatch-fun]
...)] ...)]
#:contracts #:contracts
([else-fun (request? . -> . any)] ([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. @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-case
[dispatch-pattern dispatch-fun] [dispatch-pattern
(~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
dispatch-fun]
... ...
[else else-fun]) [else else-fun])
(dispatch-case (dispatch-case
[dispatch-pattern dispatch-fun] [dispatch-pattern
(~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
dispatch-fun]
...)] ...)]
#:contracts #:contracts
([else-fun (request? . -> . any)] ([else-fun (request? . -> . any)]