1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
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 pattern-clause ...)
(let-values ([(dispatch url) (dispatch-rules pattern-clause ...)])
(container-cons! container-expr
dispatch url)))
(provide
define-container
dispatch-rules!)
(provide/contract
[container? (any/c . -> . boolean?)])
|
