From dee4c0e487c6e3408efb4e3f7c59ddef74f36c8c Mon Sep 17 00:00:00 2001
From: Cadence Ember <cadence@disroot.org>
Date: Fri, 17 Mar 2023 16:55:09 +1300
Subject: [PATCH] Referrer policy test

---
 .gitignore               |   4 ++
 info.rkt                 |   2 +
 referrer-policy-test.rkt | 106 +++++++++++++++++++++++++++++++++++++++
 req.rktd                 |   1 +
 4 files changed, 113 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 info.rkt
 create mode 100644 referrer-policy-test.rkt
 create mode 100644 req.rktd

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..fb32754
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+\#*#
+.#*
+*~
+appid.rkt
diff --git a/info.rkt b/info.rkt
new file mode 100644
index 0000000..90c7ef1
--- /dev/null
+++ b/info.rkt
@@ -0,0 +1,2 @@
+#lang info
+(define deps '("http-easy-lib" "xexpr-path" "memo"))
diff --git a/referrer-policy-test.rkt b/referrer-policy-test.rkt
new file mode 100644
index 0000000..93dd3f3
--- /dev/null
+++ b/referrer-policy-test.rkt
@@ -0,0 +1,106 @@
+#lang racket
+(require racket/draw
+         racket/set
+         web-server/servlet
+         (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
+         (prefix-in pathprocedure: web-server/dispatchers/dispatch-pathprocedure)
+         (prefix-in lift: web-server/dispatchers/dispatch-lift)
+         web-server/servlet-dispatch
+         net/url
+         file/convertible
+         file/ico
+         images/logos
+         memo)
+
+(define (req->text-lines req)
+  (define referer-header (headers-assq* #"referer" (request-headers/raw req)))
+  (define referer (if referer-header (bytes->string/utf-8 (header-value referer-header)) "<no referer>"))
+  (list (format "UrlPath: ~a" (url->string (request-uri req)))
+        (format "Referer: ~a" referer)))
+
+(define logo (convert (plt-logo #:height 32) 'png-bytes))
+
+(define/memoize (get-image lines) #:hash hash
+  (define dc (make-object bitmap-dc% #f))
+  (send dc set-font (make-object font% 12 'modern))
+  (define-values (drawings max-width total-height)
+    (for/fold ([drawings null]
+               [max-width 0]
+               [total-height 0]
+               #:result (values (reverse drawings)
+                                max-width
+                                total-height))
+              ([text lines])
+      (define-values (w1 h1 _1 _2) (send dc get-text-extent text))
+      (define-values (w h) (values (truncate (inexact->exact w1))
+                                   (truncate (inexact->exact h1))))
+      (values (cons (list text w h) drawings)
+              (max w max-width)
+              (+ h total-height))))
+  (define bm (make-object bitmap% max-width total-height #f #f))
+  (send dc set-bitmap bm)
+  (for/fold ([offset 0])
+            ([drawing drawings])
+    (send dc draw-text (car drawing) 0 offset)
+    (+ offset (caddr drawing)))
+  (convert bm 'png-bytes))
+
+(define css-paths (mutable-set))
+(define (make-css-route path extra-headers content)
+  (set-add! css-paths path)
+  (pathprocedure:make
+   path
+   (λ (req)
+     (response/output
+      #:mime-type #"text/css"
+      #:headers (append (list (header #"Cache-Control" #"no-cache"))
+                        extra-headers)
+      (λ (out) (displayln content out))))))
+
+(define main
+  (sequencer:make
+   (pathprocedure:make
+    "/"
+    (λ (req)
+      (response/xexpr
+       #:headers (list (header #"Referrer-Policy" #"no-referrer")
+                       (header #"Cache-Control" #"no-cache"))
+       #:preamble #"<!DOCTYPE text/html>"
+       `(html
+         (head (title "Referrer-Policy Header Test")
+               ,@(for/list ([path (set->list css-paths)])
+                   `(link ((rel "stylesheet") (type "text/css") (href ,path)))))
+         (body
+          (h1 "Referrer-Policy Header Test")
+          (h2 "Image from <img> element in document")
+          (div ((class "test-case")) (img ((src "/img/element"))))
+          (h2 "Image from style attribute")
+          (div ((class "test-case") (referrerpolicy "no-referrer") (style "background-image: url(/img/inline-style)")))
+          (h2 "Image from same-origin stylesheet, no extra headers")
+          (div ((class "test-case same-origin-no-extra-img")))
+          (h2 "Image from same-origin stylesheet with " (code "Referrer-Policy: no-referrer"))
+          (div ((class "test-case same-origin-policy-no-referrer-img")))
+          (h2 "Image from same-origin stylesheet with " (code "Referrer-Policy: origin"))
+          (div ((class "test-case same-origin-policy-origin-img"))))))))
+   (make-css-route "/style/default.css" null "
+body { font: 16px sans-serif; }
+.test-case { width: 100%; height: 60px; background: antiquewhite; background-repeat: no-repeat; }
+.same-origin-no-extra-img { background-image: url(/img/same-origin-no-extra); }
+")
+   (make-css-route "/style/policy-no-referrer.css" (list (header #"Referrer-Policy" #"no-referrer")) "
+.same-origin-policy-no-referrer-img { background-image: url(/img/same-origin-policy-no-referrer); }
+")
+   (make-css-route "/style/policy-origin.css" (list (header #"Referrer-Policy" #"origin")) "
+.same-origin-policy-origin-img { background-image: url(/img/same-origin-policy-origin); }
+")
+   (pathprocedure:make "/favicon.ico" (λ _ (response/output #:mime-type #"image/png" (λ (out) (displayln logo out)))))
+   (lift:make
+    (λ (req)
+      (define lines (req->text-lines req))
+      (define image (get-image lines))
+      (response/output
+       #:mime-type #"image/png"
+       #:headers (list (header #"Cache-Control" #"no-cache"))
+       (λ (out) (displayln image out)))))))
+
+(serve/launch/wait #:port 7337 (λ (quit) main))
diff --git a/req.rktd b/req.rktd
new file mode 100644
index 0000000..e2d2fc2
--- /dev/null
+++ b/req.rktd
@@ -0,0 +1 @@
+((local (".")))
-- 
2.45.2