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 select_extension headers =
    let accept = Vif.Headers.get headers "accept" in
    Cohttp.Accept.media_ranges accept
    |> Cohttp.Accept.qsort
    |> List.filter_map (fun (_q, (m, _p)) -> Util.media_to_extension m)
    |> List.find_opt Assets.is_supported_ext

  let select_language 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))
    |> List.find_opt Assets.is_supported_lang

  let select_encoding headers =
    Vif.Headers.get headers "accept-encoding"
    |> Cohttp.Accept.encodings
    |> Cohttp.Accept.qsort
    |> List.map snd
    |> List.filter_map (function
         | Cohttp.Accept.Identity -> Some `Identity
         | Deflate -> Some `DEFLATE
         | Gzip -> Some `Gzip
         | AnyEncoding -> Some Config.default_encoding
         | Encoding _ | Compress -> (* unsupported *) None)
    |> function
    | [] -> assert false
    | `Identity :: _ -> None
    | `DEFLATE :: _ -> Some `DEFLATE
    | `Gzip :: _ -> Some `Gzip
end

module Static = struct
  (* - try to find a response with an acceptable mime-type,
     - then pick the version in the most preferred language of the user,
     - and finally apply compression if that is allowed by the client
     - set ETAG header

     TODO:
       - subsequent requests of the client should provide the tag in an "If-None-Match" header
         to detect if the terms of service have changed
       - If it did not change, a "304 Not Modified" response will be returned
       - The ETAG is encoded in Crockford base-32
       - A "Taler-Terms-Version" header is generated to indicate the legal version of the terms
       - When returning a full response (not a “304 Not Modified”), the server
         should also include a “Avail-Languages” header which includes a
         comma-separated list of the languages in which the terms of service are available in

  *)

  let select_file headers kind =
    let open Syntax in
    let* ext =
      Header_util.select_extension headers
      |> Option.to_result ~none:"no acceptable mimetype"
    in
    let* lang =
      Header_util.select_language headers
      |> 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 _if_none_match = Vif.Headers.get headers "if-none-match" in
    let data =
      match select_file headers kind with
      | Error e -> Fmt.failwith "%s" e
      | Ok content -> content
    in
    let compression = Header_util.select_encoding headers in
    let* () = Vif.Response.with_string ?compression req data in
    let* () = Vif.Response.add ~field:"ETAG" (Assets.etag kind) in
    (* TODO content-type *)
    let* () = Vif.Response.add ~field:"content-type" "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