breezewiki/src/page-subdomain.rkt

#lang racket/base
(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)

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