breezewiki/src/dispatcher-tree.rkt

52 lines
2.5 KiB
Racket
Raw Normal View History

#lang racket/base
2022-09-11 07:38:20 +00:00
(require "syntax.rkt"
(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
2022-09-16 13:56:03 +00:00
dispatcher-tree
; procedure to make the tree from the hashmap
make-dispatcher-tree)
; 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))
2022-09-17 10:36:04 +00:00
(pathprocedure:make "/search" (hash-ref ds 'page-global-search))
(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)))
2022-09-09 03:42:20 +00:00
(filter:make #rx"^/[a-z-]+(/(wiki(/)?)?)?$" (lift:make (hash-ref ds 'redirect-wiki-home)))
(hash-ref ds 'static-dispatcher)
(lift:make (hash-ref ds 'page-not-found)))))))