Support X-Canonical-Origin for instance admins

src/dispatcher-tree.rkt

@@ -3,6 +3,7 @@
          (for-syntax racket/base)
          racket/string
          net/url
+         web-server/http
          (prefix-in host: web-server/dispatchers/dispatch-host)
          (prefix-in pathprocedure: web-server/dispatchers/dispatch-pathprocedure)
          (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
@@ -32,15 +33,9 @@
   (datum->syntax stx `(make-dispatcher-tree ,ds)))
 
 (define (make-dispatcher-tree ds)
-  (host:make
+  (define subdomain-dispatcher (hash-ref ds 'subdomain-dispatcher))
-   (λ (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
+   subdomain-dispatcher
    (pathprocedure:make "/" (hash-ref ds 'page-home))
    (pathprocedure:make "/proxy" (hash-ref ds 'page-proxy))
    (pathprocedure:make "/search" (hash-ref ds 'page-global-search))
@@ -51,4 +46,4 @@
    (filter:make (pregexp (format "^/~a/search$" px-wikiname)) (lift:make (hash-ref ds 'page-search)))
    (filter:make (pregexp (format "^/~a(/(wiki(/)?)?)?$" px-wikiname)) (lift:make (hash-ref ds 'redirect-wiki-home)))
    (hash-ref ds 'static-dispatcher)
-              (lift:make (hash-ref ds 'page-not-found)))))))
+   (lift:make (hash-ref ds 'page-not-found))))

src/page-subdomain.rkt

@@ -1,22 +1,65 @@
 #lang racket/base
-(require racket/path
+(require racket/match
+         racket/path
          racket/string
          net/url
          web-server/http
+         web-server/dispatchers/dispatch
+         (only-in racket/promise delay)
          (prefix-in lift: web-server/dispatchers/dispatch-lift)
          "application-globals.rkt"
          "config.rkt"
+         "syntax.rkt"
          "xexpr-utils.rkt")
 
 (provide
  subdomain-dispatcher)
 
-(define (subdomain-dispatcher subdomain)
+(module+ test
+  (require rackunit))
+
+(define (do-redirect:make subdomain canonical-origin)
   (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 (format "~a/~a/~a" canonical-origin subdomain path-string))
       (generate-redirect dest)))))
+
+(define (router req)
+  (define host (bytes->string/utf-8 (header-value (headers-assq* #"host" (request-headers/raw req)))))
+  (define x-canonical-origin (headers-assq* #"x-canonical-origin" (request-headers/raw req)))
+  (define canonical-origin
+    (cond
+      [x-canonical-origin (bytes->string/utf-8 (header-value x-canonical-origin))]
+      [(config-true? 'canonical_origin) (config-get 'canonical_origin)]
+      [#t #f]))
+  (if/out canonical-origin
+          (let* ([canonical-origin-host (url-host (string->url canonical-origin))])
+            (if/in canonical-origin-host
+                   (let* ([splitter (string-append "." (url-host (string->url canonical-origin)))]
+                          [s (string-split host splitter #:trim? #f)])
+                     (if/in (and (eq? 2 (length s)) (equal? "" (cadr s)))
+                            (list 'redirect (car s) canonical-origin)))))
+          'next-dispatcher))
+(module+ test
+  (define (qr url headers)
+    (request #"GET" (string->url url) (map (λ (h) (header (car h) (cadr h))) headers) (delay '()) #f "127.0.0.1" 10416 "127.0.0.1"))
+  (parameterize ([(config-parameter 'canonical_origin) "https://breezewiki.com"])
+    (check-equal? (router (qr "/" '((#"Host" #"breezewiki.com"))))
+                  'next-dispatcher)
+    (check-equal? (router (qr "/wiki/Spell" '((#"Host" #"magic.breezewiki.com"))))
+                  '(redirect "magic" "https://breezewiki.com"))
+    (check-equal? (router (qr "/" '((#"Host" #"magic.bw.breezewiki.com")
+                                    (#"X-Canonical-Origin" #"https://bw.breezewiki.com"))))
+                  '(redirect "magic" "https://bw.breezewiki.com"))
+    (check-equal? (router (qr "/" '((#"Host" #"magic.bwxxxxx.onion")
+                                    (#"X-Canonical-Origin" #"http://bwxxxxx.onion"))))
+                  '(redirect "magic" "http://bwxxxxx.onion"))))
+
+(define (subdomain-dispatcher conn req)
+  (match (router req)
+    [(list 'redirect subdomain canonical-origin) ((do-redirect:make subdomain canonical-origin) conn req)]
+    [_ (next-dispatcher)]))

src/syntax.rkt

@@ -37,7 +37,7 @@
           [(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)]
+           (append '(if) (walk (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