mte/src/mte.ml

(*  MTE - the MirageOS Taler Exchange
    Copyright (C) 2025 Olivier Pierre <swrup@protonmail.com>

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU Affero General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU Affero General Public License for more details.

    You should have received a copy of the GNU Affero General Public License
    along with this program.  If not, see <https://www.gnu.org/licenses/>. *)

module Header_util = struct
  let parse_accept_header =
   fun headers ->
    let accept = Vif.Headers.get headers "accept" in
    Cohttp.Accept.media_ranges accept
    |>
    (* TODO check that its not in reverse order *)
    Cohttp.Accept.qsort
    |> List.filter_map (fun (_q, (m, _p)) -> Util.media_to_extension m)

  let parse_accept_language_header headers =
    let accept_language = Vif.Headers.get headers "accept-language" in
    Cohttp.Accept.languages accept_language
    |> Cohttp.Accept.qsort
    |> List.map (fun (_q, lang) -> lang)
    |> List.map (function
         | Cohttp.Accept.AnyLanguage -> Config.default_lang
         | Language language_range -> (
             (* ignore language subtags (e.g. "en-US" -> "en") *)
             match language_range with
             | [] -> assert false
             | primary_tag :: _ -> primary_tag))
end

module Static = struct
  (* TODO handle errors:
   - bad headers
   - see what to do if usupported lang or ext *)
  (* assumes accept_ext_l and accept_lang_l to be sorted by preference *)
  let select_file ~accept_lang_l ~accept_ext_l kind =
    let open Syntax in
    let* () =
      if List.is_empty accept_ext_l then Fmt.error "empty accept header"
      else Ok ()
    in
    let* () =
      if List.is_empty accept_lang_l then
        Fmt.error "empty accept language header"
      else Ok ()
    in
    let* ext =
      accept_ext_l
      |> List.find_opt Assets.is_supported_ext
      |> Option.to_result ~none:"no acceptable mimetype"
    in
    let* lang =
      accept_lang_l
      |> List.find_opt Assets.is_supported_lang
      |> Option.to_result ~none:"no acceptable language"
    in
    let content = Assets.get_content ~lang ~ext kind in
    content

  (* TODO add headers, handle errors etc
   think on how to (not) mix error and vif monade well *)
  let static kind req _server _env =
    let open Vif.Response.Syntax in
    let headers = Vif.Request.headers req in
    let accept_ext_l = Header_util.parse_accept_header headers in
    let accept_lang_l = Header_util.parse_accept_language_header headers in
    let data =
      match select_file ~accept_lang_l ~accept_ext_l kind with
      | Error e -> Fmt.failwith "%s" e
      | Ok content -> content
    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 terms = static Assets.Terms
  let privacy = static Assets.Privacy
end

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