Supporting methods in web-server/dispatch

collects/tests/web-server/dispatch-test.rkt

@@ -14,8 +14,8 @@
          web-server/dispatch/container)
 (provide all-dispatch-tests)
 
-(define (test-request url)
+(define (test-request url #:method [method #"GET"])
-  (make-request #"GET" url null (delay null) #f "1.2.3.4" 123 "4.3.2.1"))
+  (make-request method url null (delay null) #f "1.2.3.4" 123 "4.3.2.1"))
 
 (define all-dispatch-tests
   (test-suite
@@ -285,6 +285,29 @@
    (test-suite
     "syntax"
 
+    (test-suite
+     "methods"
+     (local
+      [(define (get req i) (add1 i))
+       (define (post req i) (sub1 i))
+       (define-values (blog-dispatch blog-url blog-applies?)
+         (dispatch-rules+applies
+          [((integer-arg)) #:method "get" get]
+          [((integer-arg)) #:method "post" post]
+          [((integer-arg)) get]))
+       (define (test-blog-dispatch url method val)
+         (test-equal? url
+                      (blog-dispatch
+                       (test-request #:method method (string->url url)))
+                      val))]
+
+      (test-blog-dispatch "http://www.example.com/5" #"get" 6)
+      (test-blog-dispatch "http://www.example.com/6" #"get" 7)
+      (test-blog-dispatch "http://www.example.com/7" #"post" 6)
+      (test-blog-dispatch "http://www.example.com/8" #"post" 7)))
+
+    (test-suite
+     "applies"
      (local
       [(define (list-posts req) `(list-posts))
        (define (review-post req p) `(review-post ,p))
@@ -296,9 +319,9 @@
           [("posts" (string-arg)) review-post]
           [("archive" (integer-arg) (integer-arg)) review-archive]))
        (define (test-blog-dispatch url)
-         (test-not-false url (blog-applies? (test-request (string->url url)))))
+         (test-equal? url (blog-applies? (test-request (string->url url))) #t))
        (define (test-blog-dispatch/exn url)
-         (test-false url (blog-applies? (test-request (string->url url)))))]
+         (test-equal? url (blog-applies? (test-request (string->url url))) #f))]
 
       (test-blog-dispatch "http://www.example.com")
       (test-blog-dispatch "http://www.example.com/")
@@ -307,7 +330,7 @@
       (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-dispatch/exn "http://www.example.com/foo")))
 
     (let ()
       (define (list-posts req) `(list-posts))
@@ -476,3 +499,7 @@
            (h1 ,(number->string (+ fst snd)))))
 
   (serve/dispatch start))
+
+(module+ main
+  (require rackunit/text-ui)
+  (run-tests all-dispatch-tests))

collects/web-server/dispatch/http-expanders.rkt

@@ -15,11 +15,24 @@
      (url/path (app (lambda (ps) (map path/param-path ps))
                    (list path-pat ...)))]))
 
+(define (method-downcase x)
+  (cond
+    [(string? x)
+     (string-downcase x)]
+    [(bytes? x)
+     (method-downcase (bytes->string/utf-8 x))]
+    [else 
+     x]))
+
 (define-match-expander request/url
   (syntax-rules ()
     [(_ url-pat)
      ; req = method, url, headers, bindings, post-data, host-ip, host-port, client-ip
-     (struct request (_ url-pat _ _ _ _ _ _))]))
+     (request/url (or #f "get") url-pat)]
+    [(_ method url-pat)
+     ; req = method, url, headers, bindings, post-data, host-ip, host-port, client-ip
+     (struct request ((app method-downcase method)
+                      url-pat _ _ _ _ _ _))]))
 
 (provide url/path
          url/paths

collects/web-server/dispatch/syntax.rkt

@@ -7,11 +7,15 @@
          web-server/dispatch/http-expanders
          web-server/dispatch/bidi-match
          (for-syntax racket/base
+                     syntax/parse
                      web-server/dispatch/pattern))
 
 (define (default-else req)
   (next-dispatcher))
 
+(begin-for-syntax
+  (define default-method #'(or #f "get")))
+
 (define (string-list->url strlist)
   (url->string
    (make-url #f #f #f #f #t
@@ -22,12 +26,18 @@
              empty #f)))
 
 (define-syntax (dispatch-case stx)
-  (syntax-case stx (else)
+  (syntax-parse
-    [(_ [(path-pat ...) fun]
+      stx #:literals (else)
+      [(_ [(path-pat ...)
+           (~optional (~seq #:method method)
+                      #:defaults ([method default-method]))
+           fun]
           ...
           [else else-fun])
+       #:fail-unless 
        (for-each dispatch-pattern?
                  (syntax->list #'((path-pat ...) ...)))
+       "Not a dispatch pattern"
        (with-syntax
            ([((path-pat/id ...) ...)
              (map dispatch-pattern->dispatch-pattern/ids
@@ -48,19 +58,25 @@
              (lambda (the-req)
                (syntax-parameterize ([bidi-match-going-in? #t])
                  (match the-req
-                                    [(request/url (url/paths path-pat/id ...)) 
+                   [(request/url method (url/paths path-pat/id ...))
                     (fun the-req path-pat-id ...)]
                    ...
                    [_ (else-fun the-req)]))))))]
-    [(dc [(path-pat ...) fun]
+      [(dc [(path-pat ...) 
+            (~optional (~seq #:method method)
+                      #:defaults ([method default-method]))
+            fun]
            ...)
        (syntax/loc stx
-       (dc [(path-pat ...) fun]
+         (dc [(path-pat ...)
+              #:method method 
+              fun]
              ...
              [else default-else]))]))
 
 (define-syntax (dispatch-url stx)
-  (syntax-case stx ()
+  (syntax-parse
+      stx
     [(_ [(path-pat ...) fun]
         ...)
      (for-each dispatch-pattern?
@@ -80,10 +96,6 @@
                         (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)
@@ -105,42 +117,76 @@
               ...)))))]))
 
 (define-syntax (dispatch-rules stx)
-  (syntax-case stx (else)
+  (syntax-parse
-    [(_ [(path-pat ...) fun]
+      stx #:literals (else)
+      [(_ [(path-pat ...)
+           (~optional (~seq #:method method)
+                      #:defaults ([method default-method]))
+           fun]
           ...
           [else else-fun])
        (for-each dispatch-pattern?
                  (syntax->list #'((path-pat ...) ...)))
        (syntax/loc stx
          (values
-        (dispatch-case [(path-pat ...) fun]
+          (dispatch-case [(path-pat ...)
+                          #:method method
+                          fun]
                          ...
                          [else else-fun])
           (dispatch-url [(path-pat ...) fun]
                         ...)))]
-    [(dr [(path-pat ...) fun]
+      [(dr [(path-pat ...)
+            (~optional (~seq #:method method)
+                       #:defaults ([method default-method]))
+            fun]
            ...)
        (syntax/loc stx
-       (dr [(path-pat ...) fun]
+         (dr [(path-pat ...)
+              #:method method
+              fun]
              ...
              [else default-else]))]))
 
 (define (dispatch-succ . _) #t)
 (define (dispatch-fail . _) #f)
 
-(define-syntax-rule (dispatch-rules+applies
+(define-syntax (dispatch-rules+applies stx)
-                     [pat fun]
+  (syntax-parse
-                     ...)
+      stx #:literals (else)
+      [(_
+        [pat
+         (~optional (~seq #:method method)
+                    #:defaults ([method default-method]))
+         fun]
+        ...
+        [else else-fun])
+       (syntax/loc stx
          (let-values ([(dispatch url)
                        (dispatch-rules
-                 [pat fun]
+                        [pat #:method method fun]
-                 ...)]
+                        ...
-               [(applies? _)
+                        [else else-fun])]
+                      [(applies?)
+                       (λ (req) #t)])
+           (values dispatch url applies?)))]
+      [(_
+        [pat
+         (~optional (~seq #:method method)
+                    #:defaults ([method default-method]))
+         fun]
+        ...)
+       (syntax/loc stx
+         (let-values ([(dispatch url)
                        (dispatch-rules
-                 [pat dispatch-succ]
+                        [pat #:method method fun]
+                        ...)]
+                      [(applies?)
+                       (dispatch-case
+                        [pat #:method method dispatch-succ]
                         ...
                         [else dispatch-fail])])
-    (values dispatch url applies?)))
+           (values dispatch url applies?)))]))
 
 (provide dispatch-case
          dispatch-url

collects/web-server/scribblings/dispatch.scrbl

@@ -5,6 +5,7 @@
                      web-server/dispatchers/dispatch
                      web-server/servlet-env
                      web-server/dispatch/extend
+                     (except-in syntax/parse attribute)
                      racket/match
                      racket/list
                      net/url
@@ -103,24 +104,37 @@ or else the filesystem server will never see the requests.
 
 @section{API Reference}
 
-@defform*[#:literals (else)
+@defform*[#:literals (else ~optional ~seq syntax or)
          [(dispatch-rules
-           [dispatch-pattern dispatch-fun]
+           [dispatch-pattern
+            (~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
+            dispatch-fun]
            ...
            [else else-fun])
           (dispatch-rules
-           [dispatch-pattern dispatch-fun]
+           [dispatch-pattern
+            (~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
+            dispatch-fun]
            ...)]
          #:contracts
          ([else-fun (request? . -> . any)]
           [dispatch-fun (request? any/c ... . -> . any)])]{
- Returns two values: the first is a dispatching function with the contract @racket[(request? . -> . any)]
- that calls the appropriate @racket[dispatch-fun] based on the first @racket[dispatch-pattern] that matches the
- request's URL; the second is a URL-generating function with the contract @racket[(procedure? any/c ... . -> . string?)]
- that generates a URL using @racket[dispatch-pattern] for the @racket[dispatch-fun] given as its first argument.
 
- If @racket[else-fun] is left out, one is provided that calls @racket[(next-dispatcher)] to signal to the Web Server that this
+ Returns two values: the first is a dispatching function with the
+contract @racket[(request? . -> . any)] that calls the appropriate
+@racket[dispatch-fun] based on the first @racket[dispatch-pattern]
+that matches the request's URL (and method), the second is a URL-generating
+function with the contract @racket[(procedure? any/c ... . ->
+. string?)] that generates a URL using @racket[dispatch-pattern] for
+the @racket[dispatch-fun] given as its first argument.
+
+ If @racket[else-fun] is left out, one is provided that calls
+@racket[(next-dispatcher)] to signal to the Web Server that this
 dispatcher does not apply.
+
+ If any @racket[_method] is left out, it assumed to apply to requests
+without methods and GET methods.
+
 }
  
 @racketgrammar[dispatch-pattern
@@ -129,13 +143,17 @@ or else the filesystem server will never see the requests.
                (bidi-match-expander ... . dispatch-pattern)
                (bidi-match-expander . dispatch-pattern)]
 
-@defform*[#:literals (else)
+@defform*[#:literals (else ~optional ~seq syntax or)
          [(dispatch-rules+applies
-           [dispatch-pattern dispatch-fun]
+           [dispatch-pattern
+            (~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
+            dispatch-fun]
            ...
            [else else-fun])
           (dispatch-rules+applies
-           [dispatch-pattern dispatch-fun]
+           [dispatch-pattern
+            (~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
+            dispatch-fun]
            ...)]
          #:contracts
          ([else-fun (request? . -> . any)]
@@ -144,13 +162,17 @@ or else the filesystem server will never see the requests.
       @racket[#t] if the dispatching rules apply to the request and @racket[#f] otherwise.
       }
 
-@defform*[#:literals (else)
+@defform*[#:literals (else ~optional ~seq syntax or)
          [(dispatch-case
-           [dispatch-pattern dispatch-fun]
+           [dispatch-pattern
+            (~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
+            dispatch-fun]
            ...
            [else else-fun])
           (dispatch-case
-           [dispatch-pattern dispatch-fun]
+           [dispatch-pattern
+            (~optional (~seq #:method method) #:defaults ([method #'(or #f "get")]))
+            dispatch-fun]
            ...)]
          #:contracts
          ([else-fun (request? . -> . any)]