diff --git a/breezewiki.rkt b/breezewiki.rkt index ac60e1f..dbca428 100644 --- a/breezewiki.rkt +++ b/breezewiki.rkt @@ -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)) diff --git a/dist.rkt b/dist.rkt index 289f9bd..d0720be 100644 --- a/dist.rkt +++ b/dist.rkt @@ -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))) diff --git a/src/dispatcher-tree.rkt b/src/dispatcher-tree.rkt index 626ee09..49306d8 100644 --- a/src/dispatcher-tree.rkt +++ b/src/dispatcher-tree.rkt @@ -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))))))) diff --git a/src/page-home.rkt b/src/page-home.rkt index 102ab68..760ac17 100644 --- a/src/page-home.rkt +++ b/src/page-home.rkt @@ -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")))) diff --git a/src/page-subdomain.rkt b/src/page-subdomain.rkt new file mode 100644 index 0000000..4028a78 --- /dev/null +++ b/src/page-subdomain.rkt @@ -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)))))))