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

Supporting methods in web-server/dispatch

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

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

@ -14,8 +14,8 @@
web-server/dispatch/container)
(provide all-dispatch-tests)
(define (test-request url)
(make-request #"GET" url null (delay null) #f "1.2.3.4" 123 "4.3.2.1"))
(define (test-request url #:method [method #"GET"])
(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))

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

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

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

@ -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)
[(_ [(path-pat ...) fun]
(syntax-parse
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)
[(_ [(path-pat ...) fun]
(syntax-parse
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
[pat fun]
...)
(define-syntax (dispatch-rules+applies stx)
(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]
...)]
[(applies? _)
[pat #:method method fun]
...
[else else-fun])]
[(applies?)
(λ (req) #t)])
(values dispatch url applies?)))]
[(_
[pat
(~optional (~seq #:method method)
#:defaults ([method default-method]))
fun]
...)
(syntax/loc stx
(let-values ([(dispatch url)
(dispatch-rules
[pat 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

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

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