Dispatch based on Host header (subdomain support)

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))

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)))

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)))))))

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"))))

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)))))))