(* /terms + /privacy *)

module Cfg = struct
  let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity
  let default_mimetype = ("text", "plain")
  let default_language = "en"
  let terms_legal_version = "0"
  let terms_dir = "terms"
  let privacy_dir = "privacy"
end

let terms = Assets.load Cfg.terms_dir Config.terms_etag
let privacy = Assets.load Cfg.privacy_dir Config.privacy_etag

let asset_etag t =
  match t with `Terms -> Config.terms_etag | `Privacy -> Config.privacy_etag

let asset_data t = match t with `Terms -> terms | `Privacy -> privacy

let has_matching_etag etag headers =
  match Vifu.Headers.get headers "if-none-match" with
  | None -> false
  | Some s -> String.equal etag s

(* todo: should have a middleware for this *)
let select_encoding headers =
  let opt = Vifu.Headers.get headers "accept-encoding" in
  Cohttp.Accept.encodings opt
  |> Cohttp.Accept.qsort
  |> List.map snd
  |> List.find_map (function
    | Cohttp.Accept.Identity -> Some `Identity
    | Deflate -> Some `DEFLATE
    | Gzip -> Some `Gzip
    | AnyEncoding -> Some Cfg.default_encoding
    | Encoding _ | Compress -> None)
  |> function
  | None -> None
  | Some `Identity -> None
  | Some `DEFLATE -> Some `DEFLATE
  | Some `Gzip -> Some `Gzip

let get_accept headers =
  Vifu.Headers.get headers "accept"
  |> Cohttp.Accept.media_ranges
  |> Cohttp.Accept.qsort
  |> List.map (fun (_q, (m, _p)) -> m)

let get_accept_language headers =
  Vifu.Headers.get headers "accept-language"
  |> Cohttp.Accept.languages
  |> Cohttp.Accept.qsort
  |> List.map snd

let avail_languages t =
  let supported_languages, _, _ = asset_data t in
  Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") Fmt.string) supported_languages

let pp_mimetype fmt mime = Fmt.pf fmt "%s/%s" (fst mime) (snd mime)

let accept t =
  let _, supported_mimetypes, _ = asset_data t in
  Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") pp_mimetype) supported_mimetypes

let get_content t accept accept_language =
  let supported_languages, supported_mimetypes, content_matrix = asset_data t in
  let find_lang_index = function
    | Cohttp.Accept.AnyLanguage ->
        Array.find_index
          (fun mm' -> Cfg.default_language = mm')
          supported_languages
    | Language language_range -> (
        (* ignore language subtags (e.g. "en-US" -> "en") *)
        match language_range with
        | [] -> assert false
        | lang :: _ ->
            Array.find_index (fun mm' -> lang = mm') supported_languages)
  in
  let find_mime_index = function
    | Cohttp.Accept.AnyMedia ->
        Array.find_index (( = ) Cfg.default_mimetype) supported_mimetypes
    | MediaType (m, mm) -> Array.find_index (( = ) (m, mm)) supported_mimetypes
    | AnyMediaSubtype m ->
        Array.find_index (fun (m', _) -> m = m') supported_mimetypes
  in
  let i = List.find_map find_lang_index accept_language in
  let j = List.find_map find_mime_index accept in
  (* TODO *)
  let i = Option.get i in
  let j = Option.get j in
  (supported_languages.(i), supported_mimetypes.(j), content_matrix.(i).(j))

let aux t req _server _env =
  let headers = Vifu.Request.headers req in
  if has_matching_etag (asset_etag t) headers then Respond.not_modified ()
  else
    let compression = select_encoding headers in
    let language, mimetype, content =
      get_content t (get_accept headers) (get_accept_language headers)
    in
    (* -- *)
    let open Vifu.Response in
    let open Syntax in
    let* () = with_string ?compression req content in
    let* () = add ~field:"etag" (asset_etag t) in
    let* () = add ~field:"taler-terms-version" Cfg.terms_legal_version in
    let* () = add ~field:"accept" (accept t) in
    let* () = add ~field:"avail-languages" (avail_languages t) in
    let* () = add ~field:"content-type" (Fmt.str "%a" pp_mimetype mimetype) in
    let* () = add ~field:"content-language" language in
    respond `OK

let terms req _server _env =
  Logs.info (fun m -> m "GET /terms");
  aux `Terms req _server _env

let privacy req _server _env =
  Logs.info (fun m -> m "GET /privacy");
  aux `Privacy req _server _env