81 lines
3.8 KiB
Racket
81 lines
3.8 KiB
Racket
#lang racket/base
|
|
(require "../lib/syntax.rkt"
|
|
(for-syntax racket/base)
|
|
racket/string
|
|
net/url
|
|
web-server/http
|
|
web-server/dispatchers/dispatch
|
|
(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"
|
|
"../lib/url-utils.rkt")
|
|
|
|
(provide
|
|
; syntax to make the hashmap from names
|
|
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)))
|
|
|
|
; guard that the page returned a response, otherwise print more detailed debugging information
|
|
(define-syntax-rule (page ds name)
|
|
(λ (req)
|
|
(define dispatcher (hash-ref ds (quote name)))
|
|
(define page-response (dispatcher req))
|
|
(if (response? page-response)
|
|
page-response
|
|
(response/output
|
|
#:code 500
|
|
#:mime-type #"text/plain"
|
|
(λ (out)
|
|
(for ([port (list (current-error-port) out)])
|
|
(parameterize ([current-output-port port])
|
|
(printf "error in ~a:~n expected page to return a response~n actually returned: ~v~n"
|
|
(quote name)
|
|
page-response))))))))
|
|
|
|
(define (make-dispatcher-tree ds)
|
|
(define subdomain-dispatcher (hash-ref ds 'subdomain-dispatcher))
|
|
(define tree
|
|
(sequencer:make
|
|
subdomain-dispatcher
|
|
(pathprocedure:make "/" (page ds page-home))
|
|
(pathprocedure:make "/proxy" (page ds page-proxy))
|
|
(pathprocedure:make "/search" (page ds page-global-search))
|
|
(pathprocedure:make "/set-user-settings" (page ds page-set-user-settings))
|
|
(pathprocedure:make "/buddyfight/wiki/It_Doesn't_Work!!" (page ds page-it-works))
|
|
(filter:make (pregexp (format "^/~a/wiki/Category:.+$" px-wikiname)) (lift:make (page ds page-category)))
|
|
(filter:make (pregexp (format "^/~a/wiki/File:.+$" px-wikiname)) (lift:make (page ds page-file)))
|
|
(if (config-true? 'feature_offline::enabled)
|
|
(filter:make (pregexp (format "^/~a/wiki/.+$" px-wikiname)) (lift:make (page ds page-wiki-offline)))
|
|
(λ (_conn _req) (next-dispatcher)))
|
|
(filter:make (pregexp (format "^/~a/wiki/.+$" px-wikiname)) (lift:make (page ds page-wiki)))
|
|
(filter:make (pregexp (format "^/~a/search$" px-wikiname)) (lift:make (page ds page-search)))
|
|
(filter:make (pregexp (format "^/~a(/(wiki(/)?)?)?$" px-wikiname)) (lift:make (page ds redirect-wiki-home)))
|
|
(if (config-true? 'feature_offline::enabled)
|
|
(filter:make (pregexp (format "^/archive/~a/(styles|images)/.+$" px-wikiname)) (lift:make (page ds page-static-archive)))
|
|
(λ (_conn _req) (next-dispatcher)))
|
|
(hash-ref ds 'static-dispatcher)
|
|
(lift:make (hash-ref ds 'page-not-found))))
|
|
(make-semicolon-fixer-dispatcher tree))
|
|
|
|
(define ((make-semicolon-fixer-dispatcher orig-dispatcher) conn orig-req)
|
|
(define new-req (struct-copy request orig-req [uri (fix-semicolons-url (request-uri orig-req))]))
|
|
(orig-dispatcher conn new-req))
|