cadence/breezewiki
2
4
Fork 4
Code Issues Pull requests 1 Releases Wiki Activity

Support X-Canonical-Origin for instance admins

Browse source
This commit is contained in:
Cadence Ember 2022-11-15 22:21:12 +13:00
parent 324e34eb72
commit 1c83c0b4d3
Signed by: cadence
GPG key ID: BC1C2C61CF521B17
3 changed files with 62 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

35
src/dispatcher-tree.rkt
View file

@ -3,6 +3,7 @@
(for-syntax racket/base) (for-syntax racket/base)
racket/string racket/string
net/url net/url
web-server/http
(prefix-in host: web-server/dispatchers/dispatch-host) (prefix-in host: web-server/dispatchers/dispatch-host)
(prefix-in pathprocedure: web-server/dispatchers/dispatch-pathprocedure) (prefix-in pathprocedure: web-server/dispatchers/dispatch-pathprocedure)
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
@ -32,23 +33,17 @@
(datum->syntax stx `(make-dispatcher-tree ,ds))) (datum->syntax stx `(make-dispatcher-tree ,ds)))
(define (make-dispatcher-tree ds) (define (make-dispatcher-tree ds)
(host:make (define subdomain-dispatcher (hash-ref ds 'subdomain-dispatcher))
(λ (host-sym) (sequencer:make
(if/out (config-true? 'canonical_origin) subdomain-dispatcher
(let* ([host-header (symbol->string host-sym)] (pathprocedure:make "/" (hash-ref ds 'page-home))
[splitter (string-append "." (url-host (string->url (config-get 'canonical_origin))))] (pathprocedure:make "/proxy" (hash-ref ds 'page-proxy))
[s (string-split host-header splitter #:trim? #f)]) (pathprocedure:make "/search" (hash-ref ds 'page-global-search))
(if/in (and (eq? 2 (length s)) (equal? "" (cadr s))) (pathprocedure:make "/buddyfight/wiki/It_Doesn't_Work!!" (hash-ref ds 'page-it-works))
((hash-ref ds 'subdomain-dispatcher) (car s)))) (filter:make (pregexp (format "^/~a/wiki/Category:.+$" px-wikiname)) (lift:make (hash-ref ds 'page-category)))
(sequencer:make (filter:make (pregexp (format "^/~a/wiki/File:.+$" px-wikiname)) (lift:make (hash-ref ds 'page-file)))
(pathprocedure:make "/" (hash-ref ds 'page-home)) (filter:make (pregexp (format "^/~a/wiki/.+$" px-wikiname)) (lift:make (hash-ref ds 'page-wiki)))
(pathprocedure:make "/proxy" (hash-ref ds 'page-proxy)) (filter:make (pregexp (format "^/~a/search$" px-wikiname)) (lift:make (hash-ref ds 'page-search)))
(pathprocedure:make "/search" (hash-ref ds 'page-global-search)) (filter:make (pregexp (format "^/~a(/(wiki(/)?)?)?$" px-wikiname)) (lift:make (hash-ref ds 'redirect-wiki-home)))
(pathprocedure:make "/buddyfight/wiki/It_Doesn't_Work!!" (hash-ref ds 'page-it-works)) (hash-ref ds 'static-dispatcher)
(filter:make (pregexp (format "^/~a/wiki/Category:.+$" px-wikiname)) (lift:make (hash-ref ds 'page-category))) (lift:make (hash-ref ds 'page-not-found))))
(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)))))))

49
src/page-subdomain.rkt
View file

@ -1,22 +1,65 @@
#lang racket/base #lang racket/base
(require racket/path (require racket/match
racket/path
racket/string racket/string
net/url net/url
web-server/http web-server/http
web-server/dispatchers/dispatch
(only-in racket/promise delay)
(prefix-in lift: web-server/dispatchers/dispatch-lift) (prefix-in lift: web-server/dispatchers/dispatch-lift)
"application-globals.rkt" "application-globals.rkt"
"config.rkt" "config.rkt"
"syntax.rkt"
"xexpr-utils.rkt") "xexpr-utils.rkt")
(provide (provide
subdomain-dispatcher) subdomain-dispatcher)
(define (subdomain-dispatcher subdomain) (module+ test
(require rackunit))
(define (do-redirect:make subdomain canonical-origin)
(lift:make (lift:make
(λ (req) (λ (req)
(response-handler (response-handler
(define uri (request-uri req)) (define uri (request-uri req))
(define path (url-path uri)) (define path (url-path uri))
(define path-string (string-join (map (λ (p) (path/param-path p)) path) "/")) (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))))) (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)]))

2
src/syntax.rkt
View file

@ -37,7 +37,7 @@
[(and (pair? node) (eq? 'if/out (car node))) node] [(and (pair? node) (eq? 'if/out (car node))) node]
; -- replace if/in ; -- replace if/in
[(and (pair? node) (eq? 'if/in (car node))) [(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 ; recurse down pair head and tail
[(pair? node) (cons (walk (car node)) (walk (cdr node)))] [(pair? node) (cons (walk (car node)) (walk (cdr node)))]
; something else that can't be recursed into, so pass it through ; something else that can't be recursed into, so pass it through