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

dispatching

Browse Source 
svn: r13914
This commit is contained in:
Jay McCarthy 2009-03-03 17:26:29 +00:00
parent 8704fe05b2
commit a7126e20a5
17 changed files with 1052 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/web-server/all-web-server-tests.ss
View File

@ -10,6 +10,7 @@
"servlet/all-servlet-tests.ss"
"stuffers-test.ss"
"formlets-test.ss"
"dispatch-test.ss"
"servlet-env-test.ss")
(provide all-web-server-tests)
@ -19,6 +20,7 @@
all-http-tests
all-stuffers-tests
all-formlets-tests
all-dispatch-tests
all-configuration-tests
all-dispatchers-tests
all-lang-tests

429
collects/tests/web-server/dispatch-test.ss Normal file
View File

@ -0,0 +1,429 @@
#lang scheme
(require (planet schematics/schemeunit:3)
web-server/http
web-server/dispatchers/dispatch
net/url
scheme/stxparam
web-server/dispatch/coercion
web-server/dispatch/bidi-match
web-server/dispatch/http-expanders
web-server/dispatch/pattern
web-server/dispatch/url-patterns
web-server/dispatch/syntax
web-server/dispatch/serve)
(provide all-dispatch-tests)
(define (test-request url)
(make-request #"GET" url null 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))))
(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-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))))
(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)
(define-bidi-match-expander number-arg string->number/m number->string/m)
(define (test i r)
(cond
[(and i r)
(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]))
r)
(test-equal? (format "~S" r)
(syntax-parameterize ([bidi-match-going-in? #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]))
r)]
[r
(test-equal? (format "~S" r)
(syntax-parameterize ([bidi-match-going-in? #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
"http-expanders"
(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/"
(match (string->url "http://www.example.com/")
[(url/paths "")
#t]
[else
#f]))
(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"
(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))
a]
[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)))
a]
[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))
(test-equal? "dispatch-pattern-next-...?"
(dispatch-pattern-next-...? #'(a b))
(list #f #f))
(test-equal? "dispatch-pattern-next-...?"
(dispatch-pattern-next-...? #'(a (... ...)))
(list #t))
(test-equal? "dispatch-pattern-not-..."
(map syntax->datum (dispatch-pattern-not-... #'(a)))
'(a))
(test-equal? "dispatch-pattern-not-..."
(map syntax->datum (dispatch-pattern-not-... #'(a b)))
'(a b))
(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))))))))))
(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-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) (... ...))))
(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-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
([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]))
out-expr)
...
(test-equal? (format "out ~S" out-expr)
(syntax-parameterize ([bidi-match-going-in? #f])
(match out-expr [(arg 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])))
...
(test-false (format "out-fail ~S" out-fail-expr)
(syntax-parameterize ([bidi-match-going-in? #f])
(match out-fail-expr [(arg 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])))
(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)
(dispatch-rules
[("") list-posts]
[() list-posts]
[("posts" (string-arg)) review-post]
[("archive" (integer-arg) (integer-arg)) review-archive]))
(define (test-blog-dispatch url res)
(test-equal? url (blog-dispatch (test-request (string->url url))) res))
(define (test-blog-url url . args)
(test-equal? (format "~S" args)
(apply blog-url args)
url))
(define (test-blog-url/exn . args)
(test-exn (format "~S" args)
exn?
(lambda ()
(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"))
(test-blog-dispatch "http://www.example.com/archive/2008/02" `(review-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")
(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)
(test-blog-url/exn list-posts 50)
(test-blog-url/exn +)
(test-blog-url/exn review-post 50)
(test-blog-url/exn review-post "hello" "world")
(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")))
(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)))
(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))))
(test-suite
"serve")))
(define (test-serve/dispatch)
(define-values (start url)
(dispatch-rules
[("") get-first-number]
[("/2nd" (number-arg)) get-second-number]
[("sum" (number-arg) (number-arg)) display-sum]))
(define (get-first-number req)
`(html (head (title "First number"))
(a ([href ,(url get-second-number 50)]) (h1 "+ 50"))))
(define (get-second-number req fst)
`(html (head (title "Second number"))
(a ([href ,(url display-sum fst 100)]) (h1 "+ 100"))))
(define (display-sum req fst snd)
`(html (head (title "Sum"))
(h1 ,(number->string (+ fst snd)))))
(serve/dispatch start))
#;(test-serve/dispatch)
#;(require (planet schematics/schemeunit:3/text-ui))
#;(run-tests all-dispatch-tests)

2
collects/tests/web-server/dispatchers/dispatch-servlets-test.ss
View File

@ -60,7 +60,7 @@
(build-path example-servlets "add-v2.ss"))
(test-add-two-numbers mkd "add-ssd.ss - send/suspend/dispatch"
(build-path example-servlets "add-ssd.ss"))
(test-add-two-numbers mkd "add-ssd.ss - send/formlet"
(test-add-two-numbers mkd "add-formlets.ss - send/formlet"
(build-path example-servlets "add-formlets.ss"))
(test-equal? "count.ss - state"
(let* ([d (mkd (build-path example-servlets "count.ss"))]

39
collects/web-server/default-web-root/htdocs/servlets/examples/add-dispatch.ss Normal file
View File

@ -0,0 +1,39 @@
#lang scheme
(require web-server/servlet)
(define (extract-number req)
(string->number
(extract-binding/single
'number
(request-bindings req))))
; build-request-page : str str -> response
(define (build-request-page which-number k-url)
`(html (head (title "Enter a Number to Add"))
(body ([bgcolor "white"])
(form ([action ,k-url] [method "post"])
"Enter the " ,which-number " number to add: "
(input ([type "text"] [name "number"] [value ""]))
(input ([type "submit"] [name "enter"] [value "Enter"]))))))
(define (get-first req)
(build-request-page "First" (add-url get-second)))
(define (get-second req)
(define fst (extract-number req))
(build-request-page "Second" (add-url display-sum fst)))
(define (display-sum req fst)
(define snd (extract-number req))
`(html (head (title "Sum"))
(body ([bgcolor "white"])
(p "The answer is "
,(number->string (+ fst snd))))))
(define-values (start add-url)
(dispatch-rules
[("get-second") get-second]
[("display-sum" (integer-arg)) display-sum]
[else get-first]))
(serve/dispatch start)

7
collects/web-server/dispatch.ss Normal file
View File

@ -0,0 +1,7 @@
#lang scheme
(require web-server/dispatch/syntax
web-server/dispatch/serve
web-server/dispatch/url-patterns)
(provide (all-from-out web-server/dispatch/syntax
web-server/dispatch/serve
web-server/dispatch/url-patterns))

19
collects/web-server/dispatch/bidi-match.ss Normal file
View File

@ -0,0 +1,19 @@
#lang scheme
(require scheme/stxparam)
(define-syntax-parameter bidi-match-going-in? #t)
(define-syntax (define-bidi-match-expander stx)
(syntax-case stx ()
[(_ bidi-id in-expander out-expander)
(syntax/loc stx
(define-match-expander bidi-id
(lambda (stx)
(syntax-case stx ()
[(_ id)
(if (syntax-parameter-value #'bidi-match-going-in?)
(syntax/loc stx (in-expander id))
(syntax/loc stx (out-expander id)))]))))]))
(provide bidi-match-going-in?
define-bidi-match-expander)

22
collects/web-server/dispatch/coercion.ss Normal file
View File

@ -0,0 +1,22 @@
#lang scheme
(define (make-coerce-safe? coerce)
(lambda (x)
(with-handlers ([exn? (lambda (x) #f)])
(and (coerce x) #t))))
(define-syntax (define-coercion-match-expander stx)
(syntax-case stx ()
[(_ expander-id test? coerce)
(syntax/loc stx
(define-match-expander expander-id
(lambda (stx)
(syntax-case stx ()
[(_ id) (identifier? #'id)
(syntax/loc stx
(? test? (app coerce id)))]))))]))
(provide/contract
[make-coerce-safe? ((any/c . -> . any/c) . -> . (any/c . -> . boolean?))])
(provide
define-coercion-match-expander)

5
collects/web-server/dispatch/extend.ss Normal file
View File

@ -0,0 +1,5 @@
#lang scheme
(require web-server/dispatch/coercion
web-server/dispatch/bidi-match)
(provide (all-from-out web-server/dispatch/coercion
web-server/dispatch/bidi-match))

25
collects/web-server/dispatch/http-expanders.ss Normal file
View File

@ -0,0 +1,25 @@
#lang scheme
(require net/url
web-server/http)
(define-match-expander url/path
(syntax-rules ()
[(_ path-pat)
; url = scheme, user, host, port, absolute?, path, query, fragment
(struct url (_ _ _ _ _ path-pat _ _))]))
(define-match-expander url/paths
(syntax-rules ()
[(_ path-pat ...)
(url/path (app (lambda (ps) (map path/param-path ps))
(list path-pat ...)))]))
(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 _ _ _ _ _ _))]))
(provide url/path
url/paths
request/url)

93
collects/web-server/dispatch/pattern.ss Normal file
View File

@ -0,0 +1,93 @@
#lang scheme
; A dispatch pattern is either
; - a string
; - a bidi match expander
; - ...
(define (...? stx)
(eq? '... (syntax->datum stx)))
(define (string-syntax? stx)
(string? (syntax->datum stx)))
(define (dispatch-pattern? stx)
(define (dispatch/no-...? stx)
(syntax-case stx ()
[() #t]
[((bidi) . rest-stx)
(dispatch/...? #'rest-stx)]
[(string . rest-stx)
(string-syntax? #'string)
(dispatch/no-...? #'rest-stx)]))
(define (dispatch/...? stx)
(syntax-case stx ()
[() #t]
[((bidi) . rest-stx)
(dispatch/...? #'rest-stx)]
[(string . rest-stx)
(string-syntax? #'string)
(dispatch/no-...? #'rest-stx)]
[((... ...) . rest-stx)
(dispatch/no-...? #'rest-stx)]))
(dispatch/no-...? stx))
(define (dispatch-pattern/ids? stx)
(define (dispatch/no-...? stx)
(syntax-case stx ()
[() #t]
[((bidi id) . rest-stx)
(identifier? #'id)
(dispatch/...? #'rest-stx)]
[(string . rest-stx)
(string-syntax? #'string)
(dispatch/no-...? #'rest-stx)]))
(define (dispatch/...? stx)
(syntax-case stx ()
[() #t]
[((bidi id) . rest-stx)
(identifier? #'id)
(dispatch/...? #'rest-stx)]
[(string . rest-stx)
(string-syntax? #'string)
(dispatch/no-...? #'rest-stx)]
[((... ...) . rest-stx)
(dispatch/no-...? #'rest-stx)]))
(dispatch/no-...? stx))
(define (dispatch-pattern-not-... stx)
(filter (compose not ...?)
(syntax->list stx)))
(define (dispatch-pattern-next-...? stx)
(let loop ([l (syntax->list stx)])
(cond
[(empty? l)
empty]
[(empty? (rest l))
(list #f)]
[(...? (second l))
(list* #t (loop (rest (rest l))))]
[else
(list* #f (loop (rest l)))])))
(define (dispatch-pattern->dispatch-pattern/ids pps)
(map (lambda (pp ppi)
(cond
[(string-syntax? pp)
pp]
[(...? pp)
pp]
[else
(with-syntax ([(bidi-id) pp]
[id ppi])
(syntax/loc pp (bidi-id id)))]))
(syntax->list pps)
(generate-temporaries pps)))
(provide/contract
[string-syntax? (syntax? . -> . boolean?)]
[dispatch-pattern-next-...? (syntax? . -> . (listof boolean?))]
[dispatch-pattern-not-... (syntax? . -> . (listof syntax?))]
[dispatch-pattern->dispatch-pattern/ids (syntax? . -> . (listof syntax?))]
[dispatch-pattern? (syntax? . -> . boolean?)]
[dispatch-pattern/ids? (syntax? . -> . boolean?)])

11
collects/web-server/dispatch/serve.ss Normal file
View File

@ -0,0 +1,11 @@
#lang scheme
(require web-server/servlet-env
web-server/http)
(define (serve/dispatch dispatch)
(serve/servlet dispatch
#:servlet-path "/"
#:servlet-regexp #rx""))
(provide/contract
[serve/dispatch ((request? . -> . response/c) . -> . void)])

127
collects/web-server/dispatch/syntax.ss Normal file
View File

@ -0,0 +1,127 @@
#lang scheme
(require scheme/stxparam
net/url
web-server/dispatchers/dispatch
web-server/dispatch/http-expanders
web-server/dispatch/bidi-match
(for-syntax web-server/dispatch/pattern))
(define (default-else req)
(next-dispatcher))
(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))
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 ...) ...)))])
(with-syntax
([((path-pat-id ...) ...)
(map (lambda (pp/is)
(map (lambda (bs)
(with-syntax ([(bidi-id id) bs])
#'id))
(filter (lambda (pp/i)
(syntax-case pp/i ()
[(bidi-id 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]))]))
(define-syntax (dispatch-url stx)
(syntax-case stx ()
[(_ [(path-pat ...) fun]
...)
(for-each dispatch-pattern?
(syntax->list #'((path-pat ...) ...)))
(with-syntax
([((path-pat/id ...) ...)
(map dispatch-pattern->dispatch-pattern/ids
(syntax->list #'((path-pat ...) ...)))])
(with-syntax
([((from-path-pat ...) ...)
(map (lambda (pp/is-pre)
(define pp/is (datum->syntax pp/is-pre (filter (compose not string-syntax?) (syntax->list pp/is-pre)) pp/is-pre))
(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])
(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 ...) ...)))]
[((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 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 ...))]
...)))))]))
(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]))]))
(provide dispatch-case
dispatch-url
dispatch-rules)

56
collects/web-server/dispatch/url-patterns.ss Normal file
View File

@ -0,0 +1,56 @@
#lang scheme
(require web-server/dispatch/coercion
web-server/dispatch/bidi-match)
(define-syntax define-bidi-match-expander/coercions
(syntax-rules ()
[(_ id in-test? in out-test? out)
(begin (define-coercion-match-expander in/m in-test? in)
(define-coercion-match-expander out/m out-test? out)
(define-bidi-match-expander id in/m out/m))]))
; number arg
(define string->number? (make-coerce-safe? string->number))
(define-bidi-match-expander/coercions number-arg
string->number? string->number
number? number->string)
; integer arg
(define (string->integer x)
(define nx (string->number x))
(if (integer? nx)
nx
(error 'string->integer "Not an integer string")))
(define string->integer? (make-coerce-safe? string->integer))
(define-bidi-match-expander/coercions integer-arg
string->integer? string->integer
integer? number->string)
; real arg
(define (string->real x)
(define nx (string->number x))
(if (real? nx)
nx
(error 'string->real "Not an real string")))
(define string->real? (make-coerce-safe? string->real))
(define-bidi-match-expander/coercions real-arg
string->real? string->real
real? number->string)
; string arg
(define-match-expander string->string/m
(syntax-rules ()
[(_ str) (? string? str)]))
(define-bidi-match-expander string-arg string->string/m string->string/m)
; symbol arg
(define-bidi-match-expander/coercions symbol-arg
string? string->symbol
symbol? symbol->string)
(provide number-arg
integer-arg
real-arg
string-arg
symbol-arg)

2
collects/web-server/lang/lang-api.ss
View File

@ -1,6 +1,7 @@
#lang scheme
(require net/url
web-server/http
web-server/dispatch
web-server/stuffers
web-server/lang/abort-resume
web-server/lang/web
@ -10,6 +11,7 @@
(provide (except-out (all-from-out scheme) #%module-begin)
(all-from-out net/url
web-server/http
web-server/dispatch
web-server/stuffers
web-server/lang/abort-resume
web-server/lang/web

209
collects/web-server/scribblings/dispatch.scrbl Normal file
View File

@ -0,0 +1,209 @@
#lang scribble/doc
@(require "web-server.ss"
scheme/sandbox)
@(require (for-label web-server/servlet
web-server/dispatchers/dispatch
web-server/servlet-env
web-server/dispatch/extend
scheme/match
scheme/list
net/url
xml))
@(define dispatch-eval
(let ([the-eval (make-base-eval)])
(the-eval '(require web-server/http
net/url
scheme/list
web-server/dispatch
web-server/dispatch/extend))
the-eval))
@title[#:tag "dispatch"]{URL-Based Dispatch}
@defmodule[web-server/dispatch]
The library allows the creation of two-way mappings between permanent URLs and request-handling procedures.
@margin-note{This library was inspired by the @schememodname[(planet untyped/dispatch)] package.}
@section{Using @schememodname[web-server/dispatch]}
Suppose you are writing a blog application and want pretty URLs for different views of the site.
You would define some URL dispatching rules as follows:
@interaction[#:eval dispatch-eval
(define-values (blog-dispatch blog-url)
(dispatch-rules
[("") list-posts]
[("posts" (string-arg)) review-post]
[("archive" (integer-arg) (integer-arg)) review-archive]
[else list-posts]))
]
And define your request handlers as follows:
@interaction[#:eval dispatch-eval
(define (list-posts req) `(list-posts))
(define (review-post req p) `(review-post ,p))
(define (review-archive req y m) `(review-archive ,y ,m))
]
Now when a request is sent to your application, it will be directed to the appropriate handler:
@interaction[#:eval dispatch-eval
(define (url->request u)
(make-request #"GET" (string->url u) empty
empty #f "1.2.3.4" 80 "4.3.2.1"))
(blog-dispatch
(url->request "http://www.chrlsnchrg.com"))
(blog-dispatch
(url->request "http://www.chrlsnchrg.com/"))
(blog-dispatch
(url->request
"http://www.chrlsnchrg.com/posts/Extracurricular-Activity"))
(blog-dispatch
(url->request "http://www.chrlsnchrg.com/archive/1984/10"))
(blog-dispatch
(url->request "http://www.chrlsnchrg.com/contact"))
]
You can also generate these pretty URLs from procedure calls:
@interaction[#:eval dispatch-eval
(blog-url list-posts)
(blog-url review-post "Another-Saturday-Night")
(blog-url review-archive 1984 11)
]
After mastering the world of blogging software, you decide to put the ubiquitous Add-Two-Numbers.com out of business with Sum.com:
@interaction[#:eval dispatch-eval
(define-values (sum-dispatch sum-url)
(dispatch-rules
[((integer-arg) ...) sum]
[else (lambda (req) (sum req empty))]))
(define (sum req is)
(apply + is))
(sum-dispatch (url->request "http://www.sum.com/"))
(sum-dispatch (url->request "http://www.sum.com/2"))
(sum-dispatch (url->request "http://www.sum.com/2/3/4"))
(sum-dispatch (url->request "http://www.sum.com/5/10/15/20"))
(sum-url sum empty)
(sum-url sum (list 1))
(sum-url sum (list 2 3 5 7))
]
@section{API Reference}
@defform*[#:literals (else)
[(dispatch-rules
[dispatch-pattern dispatch-fun]
...
[else else-fun])
(dispatch-rules
[dispatch-pattern dispatch-fun]
...)]
#:contracts
([else-fun (request? . -> . response/c)]
[dispatch-fun (request? any/c ... . -> . response/c)])]{
Returns two values: the first is a dispatching function with the contract @scheme[(request? . -> . response/c)]
that calls the appropriate @scheme[dispatch-fun] based on the first @scheme[dispatch-pattern] that matches the
request's URL; the second is a URL-generating function with the contract @scheme[(procedure? any/c ... . -> . string?)]
that generates a URL using @scheme[dispatch-pattern] for the @scheme[dispatch-fun] given as its first argument.
If @scheme[else-fun] is left out, one is provided that calls @scheme[(next-dispatcher)] to signal to the Web Server that this
dispatcher does not apply.
}
@schemegrammar[dispatch-pattern
()
(string . dispatch-pattern)
(bidi-match-expander ... . dispatch-pattern)
(bidi-match-expander . dispatch-pattern)]
@defform*[#:literals (else)
[(dispatch-case
[dispatch-pattern dispatch-fun]
...
[else else-fun])
(dispatch-case
[dispatch-pattern dispatch-fun]
...)]
#:contracts
([else-fun (request? . -> . response/c)]
[dispatch-fun (request? any/c ... . -> . response/c)])]{
Returns a dispatching function as described by @scheme[dispatch-rules].
}
@defform[#:literals (else)
(dispatch-url
[dispatch-pattern dispatch-fun]
...)
#:contracts
([dispatch-fun (request? any/c ... . -> . response/c)])]{
Returns a URL-generating function as described by @scheme[dispatch-rules].
}
@defproc[(serve/dispatch [dispatch (request? . -> . response/c)])
void]{
Calls @scheme[serve/servlet] with appropriate arguments so that every request is handled by @scheme[dispatch].
}
@section{Built-in URL patterns}
@schememodname[web-server/dispatch] builds in a few useful URL component patterns.
@defform[(number-arg)]{
A @tech{bi-directional match expander} that parses a @scheme[number?] from the URL and generates a URL with a number's encoding as a string.
}
@defform[(integer-arg)]{
A @tech{bi-directional match expander} that parses a @scheme[integer?] from the URL and generates a URL with a integer's encoding as a string.
}
@defform[(real-arg)]{
A @tech{bi-directional match expander} that parses a @scheme[real?] from the URL and generates a URL with a real's encoding as a string.
}
@defform[(string-arg)]{
A @tech{bi-directional match expander} that parses a @scheme[string?] from the URL and generates a URL containing the string.
}
@defform[(symbol-arg)]{
A @tech{bi-directional match expander} that parses a @scheme[symbol?] from the URL and generates a URL with a symbol's encoding as a string.
}
@section{Extending @schememodname[web-server/dispatch]}
@defmodule[web-server/dispatch/extend]
You can create new URL component patterns by defining @tech{bi-directional match expanders}.
@defform[(define-bidi-match-expander id in-xform out-xform)]{
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.
}
@defidform[bidi-match-going-in?]{
A @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{syntax parameter} used by @tech{bi-directional match expanders} to determine if a URL is being parsed or generated.
}
When defining new patterns, you may find it useful to use these helper functions:
@defform[(define-coercion-match-expander id test? coerce)]{
Binds @scheme[id] to a match expander that expands @scheme[(id _x)] to
@scheme[(? test? (app coerce _x))] (i.e., uses @scheme[test?] to determine if the pattern matches and @scheme[coerce] to transform the binding.)
}
@defproc[(make-coerce-safe? [coerce (any/c . -> . any/c)])
(any/c . -> . boolean?)]{
Returns a function that returns @scheme[#t] if @scheme[coerce] would not throw an exception or return @scheme[#f] on its input.
@examples[#:eval dispatch-eval
(define string->number? (make-coerce-safe? string->number))
(string->number? "1")
(string->number? "1.2")
(string->number? "+inf.0")
(string->number? "one")
]
}

3
collects/web-server/scribblings/writing.scrbl
View File

@ -19,6 +19,7 @@ There are two API sets provided by the Web Server. One is for standard servlets,
This API provides:
@itemize{
@item{@schememodname[web-server/servlet/web-cells],}
@item{@schememodname[web-server/dispatch],}
@item{@schememodname[web-server/http/bindings],}
@item{@schememodname[web-server/http],}
@item{@schememodname[web-server/servlet/servlet-structs], and}
@ -32,6 +33,7 @@ This API provides:
This API provides:
@itemize{
@item{@schememodname[net/url],}
@item{@schememodname[web-server/dispatch],}
@item{@schememodname[web-server/http],}
@item{@schememodname[web-server/stuffers],}
@item{@schememodname[web-server/lang/abort-resume],}
@ -165,6 +167,7 @@ things in the Web Language, they are sensitive to source code modification.
}
@; ------------------------------------------------------------
@include-section["dispatch.scrbl"]
@include-section["formlets.scrbl"]
@include-section["templates.scrbl"]
@include-section["managers.scrbl"]

2
collects/web-server/servlet.ss
View File

@ -2,10 +2,12 @@
(require web-server/servlet/web-cells
web-server/http/bindings
web-server/http
web-server/dispatch
web-server/servlet/servlet-structs
web-server/servlet/web)
(provide (all-from-out web-server/servlet/web-cells
web-server/http/bindings
web-server/dispatch
web-server/http
web-server/servlet/servlet-structs
web-server/servlet/web))