forked from cadence/breezewiki
71 lines
3.3 KiB
Racket
71 lines
3.3 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base)
|
|
racket/string
|
|
net/url
|
|
(prefix-in host: web-server/dispatchers/dispatch-host)
|
|
(prefix-in pathprocedure: web-server/dispatchers/dispatch-pathprocedure)
|
|
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
|
|
(prefix-in lift: web-server/dispatchers/dispatch-lift)
|
|
(prefix-in filter: web-server/dispatchers/dispatch-filter)
|
|
"config.rkt")
|
|
|
|
(provide
|
|
; syntax to make the hashmap from names
|
|
dispatcher-tree
|
|
; procedure to make the tree from the hashmap
|
|
make-dispatcher-tree)
|
|
|
|
(define-syntax (if/out stx)
|
|
(define tree (cdr (syntax->datum stx))) ; condition true false
|
|
(define else (cddr tree)) ; the else branch cons cell
|
|
(define result
|
|
(let walk ([node tree])
|
|
(cond
|
|
; normally, node should be a full cons cell (a pair) but it might be something else.
|
|
; situation: reached the end of a list, empty cons cell
|
|
[(null? node) node]
|
|
; situation: reached the end of a list, cons cdr was non-list
|
|
[(symbol? node) node]
|
|
; normal situation, full cons cell
|
|
; -- don't go replacing through nested if/out
|
|
[(and (pair? node) (eq? 'if/out (car node))) node]
|
|
; -- replace if/in
|
|
[(and (pair? node) (eq? 'if/in (car node)))
|
|
(append '(if) (cdr node) else)]
|
|
; recurse down pair head and tail
|
|
[(pair? node) (cons (walk (car node)) (walk (cdr node)))]
|
|
; something else that can't be recursed into, so pass it through
|
|
[#t node])))
|
|
(datum->syntax stx (cons 'if result)))
|
|
|
|
; make a hashmap out of the provided names and call make-dispatcher-tree with it
|
|
(define-syntax (dispatcher-tree stx)
|
|
; the arguments, which are names of dispatcher variables
|
|
(define names (cdr (syntax->list stx)))
|
|
; map each name to syntax of a '(name . ,name)
|
|
(define alist (map (λ (xe) ; xe is the syntax of a name
|
|
; return instead syntax of a cons cell
|
|
(datum->syntax stx `(cons ',xe ,xe)))
|
|
names))
|
|
; make syntax to make the hash
|
|
(define ds (datum->syntax stx `(make-hasheq (list ,@alist))))
|
|
; don't forget that I'm returning *code* - return a call to the function
|
|
(datum->syntax stx `(make-dispatcher-tree ,ds)))
|
|
|
|
(define (make-dispatcher-tree ds)
|
|
(host:make
|
|
(λ (host-sym)
|
|
(if/out (config-true? 'canonical_origin)
|
|
(let* ([host-header (symbol->string host-sym)]
|
|
[splitter (string-append "." (url-host (string->url (config-get 'canonical_origin))))]
|
|
[s (string-split host-header splitter #:trim? #f)])
|
|
(if/in (and (eq? 2 (length s)) (equal? "" (cadr s)))
|
|
((hash-ref ds 'subdomain-dispatcher) (car s))))
|
|
(sequencer:make
|
|
(pathprocedure:make "/" (hash-ref ds 'page-home))
|
|
(pathprocedure:make "/proxy" (hash-ref ds 'page-proxy))
|
|
(filter:make #rx"^/[a-z-]+/wiki/Category:.+$" (lift:make (hash-ref ds 'page-category)))
|
|
(filter:make #rx"^/[a-z-]+/wiki/.+$" (lift:make (hash-ref ds 'page-wiki)))
|
|
(filter:make #rx"^/[a-z-]+/search$" (lift:make (hash-ref ds 'page-search)))
|
|
(hash-ref ds 'static-dispatcher)
|
|
(lift:make (hash-ref ds 'page-not-found)))))))
|