dispatching

svn: r13914

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

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)

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"))]

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)

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))

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)

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)

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))

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)

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?)])

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)])

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)

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)

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

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")
+ ]
+}

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"]

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))