Refactor Referrer-Policy header

- Change the variable to always-headers so it can be extended in the future
- New function build-headers that assists combining complex logic headers
  together with less mess
- Also apply headers to the proxy

src/application-globals.rkt

@@ -9,8 +9,8 @@
          "url-utils.rkt")
 
 (provide
- ; header to not send referers to fandom
+ ; headers to always send on all http responses
- referrer-policy
+ always-headers
  ; timeout durations for http-easy requests
  timeouts
  ; generates a consistent footer
@@ -24,7 +24,8 @@
   (require rackunit
            html-writing))
 
-(define referrer-policy (header #"Referrer-Policy" #"no-referrer"))
+(define always-headers
+  (list (header #"Referrer-Policy" #"same-origin"))) ; header to not send referers to fandom
 (define timeouts (easy:make-timeout-config #:lease 5 #:connect 5))
 
 (define (application-footer source-url #:license [license-in #f])

src/page-category.rkt

@@ -113,7 +113,7 @@
       (xexp->html body))
     (response/output
      #:code 200
-     #:headers (list referrer-policy)
+     #:headers (build-headers always-headers)
      (λ (out)
        (write-html body out))))))
 (module+ test

src/page-home.rkt

@@ -4,6 +4,7 @@
          html-writing
          web-server/http
          "application-globals.rkt"
+         "url-utils.rkt"
          "xexpr-utils.rkt"
          "config.rkt")
 
@@ -81,6 +82,7 @@
 (define (page-home req)
   (response/output
    #:code 200
+   #:headers (build-headers always-headers)
    (λ (out)
      (write-html body out))))
 

src/page-proxy.rkt

@@ -8,6 +8,7 @@
          net/url
          web-server/http
          (only-in web-server/dispatchers/dispatch next-dispatcher)
+         "application-globals.rkt"
          "url-utils.rkt"
          "xexpr-utils.rkt")
 
@@ -26,6 +27,7 @@
               (response/output
                #:code (easy:response-status-code dest-r)
                #:mime-type (easy:response-headers-ref dest-r 'content-type)
+               #:headers (build-headers always-headers)
                (λ (out)
                  (copy-port (easy:response-output dest-r) out)
                  (easy:response-close! dest-r))))))

src/page-search.rkt

@@ -81,7 +81,7 @@
       (xexp->html body))
     (response/output
      #:code 200
-     #:headers (list referrer-policy)
+     #:headers (build-headers always-headers)
      (λ (out)
        (write-html body out))))))
 (module+ test

src/page-wiki.rkt

@@ -277,11 +277,13 @@
                 #:body-class body-class
                 #:siteinfo siteinfo))
              (define redirect-msg ((query-selector (attribute-selector 'class "redirectMsg") body)))
-             (define headers (if redirect-msg
+             (define headers
-                                 (let* ([dest (get-attribute 'href (bits->attributes ((query-selector (λ (t a c) (eq? t 'a)) redirect-msg))))]
+               (build-headers
-                                        [value (bytes-append #"0;url=" (string->bytes/utf-8 dest))])
+                always-headers
-                                   (list (header #"Refresh" value) referrer-policy))
+                (when redirect-msg
-                                 (list referrer-policy)))
+                    (let* ([dest (get-attribute 'href (bits->attributes ((query-selector (λ (t a c) (eq? t 'a)) redirect-msg))))]
+                           [value (bytes-append #"0;url=" (string->bytes/utf-8 dest))])
+                      (header #"Refresh" value)))))
              (when (config-true? 'debug)
                ; used for its side effects
                ; convert to string with error checking, error will be raised if xexp is invalid

src/url-utils.rkt

@@ -2,6 +2,8 @@
 (require racket/string
          "config.rkt"
          "pure-utils.rkt")
+(require/typed web-server/http/request-structs
+               [#:opaque Header header?])
 
 (provide
  ; regex to match wiki names
@@ -13,7 +15,9 @@
  ; check whether a url is on a domain controlled by fandom
  is-fandom-url?
   ; prints "out: <url>"
- log-outgoing)
+ log-outgoing
+ ; pass in a header, headers, or something useless. they'll all combine into a list
+ build-headers)
 
 (module+ test
   (require "typed-rackunit.rkt"))
@@ -81,3 +85,16 @@
 (define (log-outgoing url-string)
   (when (config-true? 'log_outgoing)
     (printf "out: ~a~n" url-string)))
+
+(: build-headers ((U Header (Listof Header) False Void) * -> (Listof Header)))
+(define (build-headers . fs)
+  (apply
+   append
+   (map (λ ([f : (U Header (Listof Header) False Void)])
+         (cond
+           [(not f) null]
+           [(void? f) null]
+           [(null? f) null]
+           [(header? f) (list f)]
+           [(pair? f) f]))
+       fs)))