127 lines
4.9 KiB
Scheme
127 lines
4.9 KiB
Scheme
#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) |