mte/src/mte.ml

module Assets = struct
  let get path =
    let path = Fpath.to_string path in
    match Assets.read path with
    | None -> Fmt.failwith "asset loading failure `%s`" path
    | Some data -> data
end

let static _kind req _server _env =
  let open Vif.Response.Syntax in
  let headers = Vif.Request.headers req in
  let media_l =
    let accept = Vif.Headers.get headers "accept" in
    Cohttp.Accept.media_ranges accept
    |> Cohttp.Accept.qsort
    |> List.map (fun (_q, (m, _p)) -> m)
  in
  let accept_language_l =
    let accept_language = Vif.Headers.get headers "accept-language" in
    Cohttp.Accept.languages accept_language
    |> Cohttp.Accept.qsort
    |> List.map (fun (_q, lang) -> lang)
    |>
    (* ignore language subtags *)
    List.map (function
      | Cohttp.Accept.AnyLanguage -> "*"
      | Language l -> (
          match l with
          | [] -> Fmt.failwith "language subtags error"
          | primary_tag :: _ -> primary_tag))
  in
  (* todo: not sure what to do if no accept-lenguage header *)
  assert (List.length accept_language_l > 0);
  (* find an approriate extension + supported lang_l *)
  let opt =
    media_l
    |> List.find_map (fun media ->
           match media with
           | Cohttp.Accept.MediaType (m, m_sub) ->
               List.assoc_opt (m, m_sub) Config.terms_assoc
           | AnyMediaSubtype m ->
               List.find_opt
                 (fun ((mm, _), _) -> String.equal m mm)
                 Config.terms_assoc
               |> Option.map snd
           | AnyMedia -> List.nth_opt Config.terms_assoc 0 |> Option.map snd)
  in
  let lang, ext =
    match opt with
    | None ->
        (* todo respond with smthing approriate *)
        Fmt.failwith "usuported mimetype"
    | Some (ext, lang_l) -> (
        (* pick best language to use *)
        match Config.preferred_lang ~supported:lang_l accept_language_l with
        | None ->
            (* todo respond with smthing approriate *)
            Fmt.failwith "usuported accepted language"
        | Some lang -> (lang, ext))
  in
  (* todo add headers ... *)
  let data =
    Assets.get @@ Fpath.((Config.terms_dir / lang / Config.terms_etag) + ext)
  in
  let* () = Vif.Response.with_string ~compression:`Gzip req data in
  let field = "content-type" in
  let* () = Vif.Response.add ~field "html; charset=utf-8" in
  Vif.Response.respond `OK

let routes =
  let open Vif.Uri in
  let open Vif.Route in
  (*let open Vif.Type in*)
  [
    get (rel / "terms" /?? nil) --> static `Terms
  ; get (rel / "privacy" /?? nil) --> static `Privacy
  ]

let () =
  Miou_unix.run @@ fun () ->
  let env = () in
  let middlewares = Vif.Middlewares.[] in
  Vif.run ~middlewares routes env