Dispatch based on Host header (subdomain support)

This commit is contained in:
Cadence Ember 2022-09-05 01:32:45 +12:00
parent 8a72003170
commit 4815db4063
Signed by untrusted user: cadence
GPG key ID: BC1C2C61CF521B17
5 changed files with 87 additions and 12 deletions

View file

@ -15,6 +15,7 @@
(require-reloadable "src/page-proxy.rkt" page-proxy)
(require-reloadable "src/page-search.rkt" page-search)
(require-reloadable "src/page-static.rkt" static-dispatcher)
(require-reloadable "src/page-subdomain.rkt" subdomain-dispatcher)
(require-reloadable "src/page-wiki.rkt" page-wiki)
(reload!)
@ -34,6 +35,7 @@
page-proxy
page-search
page-wiki
static-dispatcher))))
static-dispatcher
subdomain-dispatcher))))
(define server-t (thread start))
(define quit (channel-get ch))

View file

@ -9,6 +9,7 @@
(require (only-in "src/page-proxy.rkt" page-proxy))
(require (only-in "src/page-search.rkt" page-search))
(require (only-in "src/page-static.rkt" static-dispatcher))
(require (only-in "src/page-subdomain.rkt" subdomain-dispatcher))
(require (only-in "src/page-wiki.rkt" page-wiki))
(serve/launch/wait
@ -23,4 +24,5 @@
page-proxy
page-search
page-wiki
static-dispatcher)))
static-dispatcher
subdomain-dispatcher)))

View file

@ -1,9 +1,13 @@
#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))
(prefix-in filter: web-server/dispatchers/dispatch-filter)
"config.rkt")
(provide
; syntax to make the hashmap from names
@ -11,6 +15,29 @@
; 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
@ -26,11 +53,19 @@
(datum->syntax stx `(make-dispatcher-tree ,ds)))
(define (make-dispatcher-tree ds)
(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))))
(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)))))))

View file

@ -38,7 +38,7 @@
(define body
`(html
(head
(meta (@ (name ")viewport") (content "width=device-width, initial-scale=1")))
(meta (@ (name "viewport") (content "width=device-width, initial-scale=1")))
(title "About | BreezeWiki")
(link (@ (rel "stylesheet") (type "text/css") (href "/static/internal.css")))
(link (@ (rel "stylesheet") (type "text/css") (href "/static/main.css"))))

36
src/page-subdomain.rkt Normal file
View file

@ -0,0 +1,36 @@
#lang racket/base
(require racket/path
racket/string
net/url
web-server/http
web-server/servlet-dispatch
html-writing
(prefix-in lift: web-server/dispatchers/dispatch-lift)
"config.rkt"
"xexpr-utils.rkt")
(provide
subdomain-dispatcher)
(define (subdomain-dispatcher subdomain)
(lift:make
(λ (req)
(response-handler
(define uri (request-uri req))
(define path (url-path uri))
(define path-string (string-join (map (λ (p) (path/param-path p)) path) "/"))
(define dest (format "~a/~a/~a" (config-get 'canonical_origin) subdomain path-string))
(define dest-bytes (string->bytes/utf-8 dest))
(response/output
#:code 302
#:headers (list (header #"Location" dest-bytes))
(λ (out)
(write-html
`(html
(head
(title "Redirecting..."))
(body
"Redirecting to "
(a (@ (href ,dest)) ,dest)
"..."))
out)))))))