~cadence/referrer-policy-test

dee4c0e487c6e3408efb4e3f7c59ddef74f36c8c — Cadence Ember 11 months ago
Referrer policy test
4 files changed, 113 insertions(+), 0 deletions(-)

A .gitignore
A info.rkt
A referrer-policy-test.rkt
A req.rktd
A  => .gitignore +4 -0
@@ 1,4 @@
\#*#
.#*
*~
appid.rkt

A  => info.rkt +2 -0
@@ 1,2 @@
#lang info
(define deps '("http-easy-lib" "xexpr-path" "memo"))

A  => referrer-policy-test.rkt +106 -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))

A  => req.rktd +1 -0
@@ 1,1 @@
((local (".")))