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

  module Etag : sig
    (* TODO
       - test
       - don't ignore broken etag format *)
    [@@@ocaml.warning "-32"]

    (* https://httpwg.org/specs/rfc9110.html#field.etag
       module to parse < "*" / #entity-tag >
       for If-Match and If-None-Match header value *)
    type etag = private { weak: bool; value: string }
    type t = Any_etag | Etag_list of etag list

    val parse : string -> t
    val of_crockford32 : string -> (t, string) result
    val to_field_value : t -> string
  end = struct
    type etag = { weak: bool; value: string }
    type t = Any_etag | Etag_list of etag list

    let invalid_etag = Error "invalid Etag field"

    let is_valid_etag_string s =
      let f c =
        let n = Char.code c in
        (n >= 0x21 && n <= 0x7E && n <> 0x22) || (n >= 0x80 && n <= 0xFF)
      in
      String.for_all f s

    let pp_etag ppf { weak; value } =
      if weak then Fmt.pf ppf {|W/"%s"|} value else Fmt.pf ppf {|"%s"|} value

    let pp_etag_list = Fmt.list ~sep:(Fmt.any ", ") pp_etag

    let pp ppf = function
      | Any_etag -> Fmt.pf ppf "*"
      | Etag_list etags -> Fmt.pf ppf "%a" pp_etag_list etags

    let to_field_value t = Fmt.str "%a" pp t

    let of_crockford32 s =
      (* always weak for If-None-Match *)
      let weak = true in
      match is_valid_etag_string s with
      | false -> invalid_etag
      | true ->
          let v = Etag_list [ { weak; value= s } ] in
          Ok v

    let unquote s =
      let len = String.length s in
      if len >= 2 && s.[0] = '"' && s.[len - 1] = '"' then
        Ok (String.sub s 1 (len - 2))
      else invalid_etag

    let parse s =
      if String.trim s = "*" then Any_etag
      else
        String.split_on_char ',' s
        |> List.map String.trim
        |> List.filter (( <> ) "")
        |> List.map (fun s ->
               (* "W/" is the weak comparison indicator *)
               let weak, s =
                 if String.starts_with ~prefix:"W/" s then
                   (true, String.sub s 2 (String.length s - 2))
                 else (false, s)
               in
               Result.bind (unquote s) (fun s ->
                   if is_valid_etag_string s then Ok { weak; value= s }
                   else invalid_etag))
        |> List.filter_map Result.to_option
        |> fun l -> Etag_list l
  end
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