#lang racket/base

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Shared HTTP request/response helpers and security headers.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require json
         racket/string
         web-server/http
         web-server/http/json
         web-server/http/xexpr)

(provide json-response
         json-error
         html-response
         redirect-response
         request-json
         request-header/string
         bytes-response
         extension->mime)

(define security-headers
  (list (make-header #"X-Content-Type-Options" #"nosniff")
        (make-header #"Referrer-Policy" #"same-origin")
        (make-header #"Content-Security-Policy"
                     #"default-src 'self'; img-src 'self' data:; style-src 'self' 'unsafe-inline'; script-src 'self'; connect-src 'self'; object-src 'none'; base-uri 'self'; form-action 'self'; frame-ancestors 'none'")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create a JSON HTTP response with the standard security headers.
; pre    : value is JSON encodable and headers contains HTTP headers.
; post   : No external state has been changed.
; result : An HTTP response value.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (json-response value #:code [code 200] #:headers [headers '()])
  (response/jsexpr value
                   #:code code
                   #:headers (append security-headers headers)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create a JSON error response.
; pre    : code is an HTTP status code and message is displayable JSON text.
; post   : No external state has been changed.
; result : An HTTP JSON response containing ok = #f and the error message.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (json-error code message)
  (json-response (hash 'ok #f 'error message) #:code code))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create an HTML response from an X-expression.
; pre    : value is a valid X-expression and headers contains HTTP headers.
; post   : No external state has been changed.
; result : An HTTP HTML response with the standard security headers.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (html-response value #:code [code 200] #:headers [headers '()])
  (response/xexpr value
                  #:code code
                  #:headers (append security-headers headers)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create a no-cache HTTP redirect response.
; pre    : location is an absolute-path URL string for this server and headers
;          contains optional response headers.
; post   : No external state has been changed.
; result : An HTTP 303 response with a Location header and the supplied headers.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (redirect-response location #:headers [headers '()])
  (response/full 303
                 #"See Other"
                 (current-seconds)
                 #"text/plain; charset=utf-8"
                 (append security-headers
                         headers
                         (list (make-header #"Location"
                                            (string->bytes/utf-8 location))
                               (make-header #"Cache-Control" #"no-store")))
                 (list #"")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Decode the JSON request body.
; pre    : req is a web-server request whose body is empty or valid JSON.
; post   : The request has only been inspected.
; result : The decoded JSON value, or an empty hash for an empty body.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (request-json req)
  (define body (request-post-data/raw req))
  (if body
      (bytes->jsexpr body)
      (hash)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Read a request header as UTF-8 text.
; pre    : req is a web-server request and name is a header name string.
; post   : The request has only been inspected.
; result : The header value as a string, or #f when absent.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (request-header/string req name)
  (define found
    (headers-assq* (string->bytes/utf-8 name)
                   (request-headers/raw req)))
  (and found
       (bytes->string/utf-8 (header-value found))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create an HTTP response containing bytes.
; pre    : bytes is the response body, mime is a MIME byte string and headers contains HTTP headers.
; post   : No external state has been changed.
; result : An HTTP response value.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (bytes-response bytes mime #:headers [headers '()])
  (response/full 200
                 #f
                 (current-seconds)
                 mime
                 (append security-headers headers)
                 (list bytes)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Map a supported filename extension to a MIME type.
; pre    : filename is a string.
; post   : No external state has been changed.
; result : A MIME byte string; application/octet-stream when the extension is unknown.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (extension->mime filename)
  (define lower (string-downcase filename))
  (cond
    ((regexp-match? #px"[.]png$" lower) #"image/png")
    ((regexp-match? #px"[.](jpg|jpeg)$" lower) #"image/jpeg")
    ((regexp-match? #px"[.]gif$" lower) #"image/gif")
    ((regexp-match? #px"[.]webp$" lower) #"image/webp")
    ((regexp-match? #px"[.]pdf$" lower) #"application/pdf")
    ((regexp-match? #px"[.]txt$" lower) #"text/plain; charset=utf-8")
    (else #"application/octet-stream")))