diff --git a/collects/tests/web-server/all-web-server-tests.ss b/collects/tests/web-server/all-web-server-tests.ss index ea44c8a081..cf9a6b28a7 100644 --- a/collects/tests/web-server/all-web-server-tests.ss +++ b/collects/tests/web-server/all-web-server-tests.ss @@ -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 diff --git a/collects/tests/web-server/dispatch-test.ss b/collects/tests/web-server/dispatch-test.ss new file mode 100644 index 0000000000..aa5224847e --- /dev/null +++ b/collects/tests/web-server/dispatch-test.ss @@ -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) \ No newline at end of file diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss index cb96d59275..2d572d5f53 100644 --- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss @@ -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"))] diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/add-dispatch.ss b/collects/web-server/default-web-root/htdocs/servlets/examples/add-dispatch.ss new file mode 100644 index 0000000000..8dd360c08d --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/add-dispatch.ss @@ -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) \ No newline at end of file diff --git a/collects/web-server/dispatch.ss b/collects/web-server/dispatch.ss new file mode 100644 index 0000000000..a8425d55a3 --- /dev/null +++ b/collects/web-server/dispatch.ss @@ -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)) \ No newline at end of file diff --git a/collects/web-server/dispatch/bidi-match.ss b/collects/web-server/dispatch/bidi-match.ss new file mode 100644 index 0000000000..2aef9c93c8 --- /dev/null +++ b/collects/web-server/dispatch/bidi-match.ss @@ -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) \ No newline at end of file diff --git a/collects/web-server/dispatch/coercion.ss b/collects/web-server/dispatch/coercion.ss new file mode 100644 index 0000000000..08704e8811 --- /dev/null +++ b/collects/web-server/dispatch/coercion.ss @@ -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) \ No newline at end of file diff --git a/collects/web-server/dispatch/extend.ss b/collects/web-server/dispatch/extend.ss new file mode 100644 index 0000000000..030f21c0b1 --- /dev/null +++ b/collects/web-server/dispatch/extend.ss @@ -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)) \ No newline at end of file diff --git a/collects/web-server/dispatch/http-expanders.ss b/collects/web-server/dispatch/http-expanders.ss new file mode 100644 index 0000000000..7b4bbb8873 --- /dev/null +++ b/collects/web-server/dispatch/http-expanders.ss @@ -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) \ No newline at end of file diff --git a/collects/web-server/dispatch/pattern.ss b/collects/web-server/dispatch/pattern.ss new file mode 100644 index 0000000000..412d9d7f24 --- /dev/null +++ b/collects/web-server/dispatch/pattern.ss @@ -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?)]) \ No newline at end of file diff --git a/collects/web-server/dispatch/serve.ss b/collects/web-server/dispatch/serve.ss new file mode 100644 index 0000000000..f879778d5e --- /dev/null +++ b/collects/web-server/dispatch/serve.ss @@ -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)]) \ No newline at end of file diff --git a/collects/web-server/dispatch/syntax.ss b/collects/web-server/dispatch/syntax.ss new file mode 100644 index 0000000000..2e10002da4 --- /dev/null +++ b/collects/web-server/dispatch/syntax.ss @@ -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) \ No newline at end of file diff --git a/collects/web-server/dispatch/url-patterns.ss b/collects/web-server/dispatch/url-patterns.ss new file mode 100644 index 0000000000..005dd83cca --- /dev/null +++ b/collects/web-server/dispatch/url-patterns.ss @@ -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) \ No newline at end of file diff --git a/collects/web-server/lang/lang-api.ss b/collects/web-server/lang/lang-api.ss index 9c2282f84b..c4a7b5efe3 100644 --- a/collects/web-server/lang/lang-api.ss +++ b/collects/web-server/lang/lang-api.ss @@ -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 diff --git a/collects/web-server/scribblings/dispatch.scrbl b/collects/web-server/scribblings/dispatch.scrbl new file mode 100644 index 0000000000..fac8cbb092 --- /dev/null +++ b/collects/web-server/scribblings/dispatch.scrbl @@ -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") + ] +} diff --git a/collects/web-server/scribblings/writing.scrbl b/collects/web-server/scribblings/writing.scrbl index 435038e1c0..fb3569a5af 100644 --- a/collects/web-server/scribblings/writing.scrbl +++ b/collects/web-server/scribblings/writing.scrbl @@ -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"] diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index 65acb8629d..5a339fe525 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -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))