From 1c83c0b4d3ce543b05befa981eccc4bfe1f440e5 Mon Sep 17 00:00:00 2001 From: Cadence Ember Date: Tue, 15 Nov 2022 22:21:12 +1300 Subject: [PATCH] Support X-Canonical-Origin for instance admins --- src/dispatcher-tree.rkt | 35 +++++++++++++---------------- src/page-subdomain.rkt | 49 ++++++++++++++++++++++++++++++++++++++--- src/syntax.rkt | 2 +- 3 files changed, 62 insertions(+), 24 deletions(-) diff --git a/src/dispatcher-tree.rkt b/src/dispatcher-tree.rkt index 9e072bc..63c053d 100644 --- a/src/dispatcher-tree.rkt +++ b/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,23 +33,17 @@ (datum->syntax stx `(make-dispatcher-tree ,ds))) (define (make-dispatcher-tree ds) - (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)) - (pathprocedure:make "/search" (hash-ref ds 'page-global-search)) - (pathprocedure:make "/buddyfight/wiki/It_Doesn't_Work!!" (hash-ref ds 'page-it-works)) - (filter:make (pregexp (format "^/~a/wiki/Category:.+$" px-wikiname)) (lift:make (hash-ref ds 'page-category))) - (filter:make (pregexp (format "^/~a/wiki/File:.+$" px-wikiname)) (lift:make (hash-ref ds 'page-file))) - (filter:make (pregexp (format "^/~a/wiki/.+$" px-wikiname)) (lift:make (hash-ref ds 'page-wiki))) - (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))))))) + (define subdomain-dispatcher (hash-ref ds 'subdomain-dispatcher)) + (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)) + (pathprocedure:make "/buddyfight/wiki/It_Doesn't_Work!!" (hash-ref ds 'page-it-works)) + (filter:make (pregexp (format "^/~a/wiki/Category:.+$" px-wikiname)) (lift:make (hash-ref ds 'page-category))) + (filter:make (pregexp (format "^/~a/wiki/File:.+$" px-wikiname)) (lift:make (hash-ref ds 'page-file))) + (filter:make (pregexp (format "^/~a/wiki/.+$" px-wikiname)) (lift:make (hash-ref ds 'page-wiki))) + (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)))) diff --git a/src/page-subdomain.rkt b/src/page-subdomain.rkt index dededfb..c254236 100644 --- a/src/page-subdomain.rkt +++ b/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)])) diff --git a/src/syntax.rkt b/src/syntax.rkt index 8205326..f8fda0d 100644 --- a/src/syntax.rkt +++ b/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