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

Adding containers

Browse Source
This commit is contained in:
Jay McCarthy 2010-11-26 19:47:43 -05:00
parent eee5c6b14a
commit ee2b11630f
4 changed files with 138 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -10,7 +10,8 @@
web-server/dispatch/pattern
web-server/dispatch/url-patterns
web-server/dispatch/syntax
web-server/dispatch/serve)
web-server/dispatch/serve
web-server/dispatch/container)
(provide all-dispatch-tests)
(define (test-request url)
@ -308,52 +309,72 @@
(test-blog-dispatch/exn "http://www.example.com/archive/2008/post")
(test-blog-dispatch/exn "http://www.example.com/foo"))
(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))))))]
(let ()
(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 (make-dispatch-test-suite blog-dispatch blog-url)
(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")))
(test-suite
"blog"
"dispatch"
(let ()
(define-values (blog-dispatch blog-url)
(dispatch-rules
[("") list-posts]
[() list-posts]
[("posts" (string-arg)) review-post]
[("archive" (integer-arg) (integer-arg)) review-archive]))
(make-dispatch-test-suite blog-dispatch blog-url))
(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")))
(let ()
(define-container blog-container
(blog-dispatch blog-url))
(dispatch-rules! blog-container
[("") list-posts])
(dispatch-rules! blog-container
[() list-posts])
(dispatch-rules! blog-container
[("posts" (string-arg)) review-post])
(dispatch-rules! blog-container
[("archive" (integer-arg) (integer-arg)) review-archive])
(make-dispatch-test-suite blog-dispatch blog-url))))
(local
[(define (sum req as) (apply + as))
@ -454,4 +475,4 @@
`(html (head (title "Sum"))
(h1 ,(number->string (+ fst snd)))))
(serve/dispatch start))
(serve/dispatch start))

6
collects/web-server/dispatch.rkt
View File

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

56
collects/web-server/dispatch/container.rkt Normal file
View File

@ -0,0 +1,56 @@
#lang racket/base
(require web-server/dispatchers/dispatch
racket/list
racket/contract
racket/match
"syntax.rkt")
(struct container (bunches) #:mutable)
(struct bunch (dispatch url))
(define (container-dispatch c)
(λ (req)
(let/ec esc
(for ([d*u (in-list (container-bunches c))])
(with-handlers ([exn:dispatcher? void])
(esc ((bunch-dispatch d*u) req))))
(next-dispatcher))))
(define (container-url c)
(λ args
(let/ec esc
(for ([d*u (in-list (container-bunches c))])
(with-handlers ([exn:misc:match? void])
(esc (apply (bunch-url d*u) args))))
(match args))))
(define-syntax-rule (define-container container-id (container-dispatch-id container-url-id))
(begin
(define container-id
(container empty))
(define container-dispatch-id
(container-dispatch container-id))
(define container-url-id
(container-url container-id))))
(define (container-cons! c d u)
(set-container-bunches!
c
(cons (bunch d u) (container-bunches c))))
#;(define (snoc l x) (append l (list x)))
#;(define (container-snoc! c d u)
(set-container-bunches!
c
(snoc (container-bunches c) (bunch d u))))
(define-syntax-rule (dispatch-rules! container-expr [pat fun] ...)
(let-values ([(dispatch url) (dispatch-rules [pat fun] ...)])
(container-cons! container-expr
dispatch url)))
(provide
define-container
dispatch-rules!)
(provide/contract
[container? (any/c . -> . boolean?)])

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

@ -165,6 +165,18 @@ After mastering the world of blogging software, you decide to put the ubiquitous
Calls @racket[serve/servlet] with a @racket[#:servlet-regexp] argument (@racket[#rx""]) so that every request is handled by @racket[dispatch].
}
@section{Imperative Dispatch Containers}
@racket[dispatch-rules] is purely functional. This presents a more declarative interface, but inhibits some programming and modularity patterns. @deftech{Containers} provide an imperative overlay atop @racket[dispatch-rules].
@defproc[(container? [x any/c]) boolean?]{ Identifies @tech{containers}. }
@defform[(define-container container-id (dispatch-id url-id))]{
Defines @racket[container-id] as a container as well as @racket[dispatch-id] as its dispatching function and @racket[url-id] as its URL lookup function.}
@defform[(dispatch-rules! container-expr [dispatch-pattern dispatch-fun] ...)]{
Like @racket[dispatch-rules], but imperatively adds the patterns to the container specified by @racket[container-expr]. The new rules are consulted @emph{before} any rules already in the container. }
@section{Built-in URL patterns}
@racketmodname[web-server/dispatch] builds in a few useful URL component patterns.