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, version 3.

    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/>. *)

let detail_tag : string Logs.Tag.def =
  Logs.Tag.def "Detail tag" ~doc:"" Fmt.string

let detail s = Logs.Tag.(empty |> add detail_tag s)
let time_anchor = Ptime_clock.now () |> Ptime.to_span

let log_level_color = function
  | Logs.App -> `White
  | Error -> `Red
  | Warning -> `Yellow
  | Info -> `Blue
  | Debug -> `Magenta

let reporter : Logs.reporter =
  let open Fmt in
  let pp_header ppf v =
    let color = fst v |> log_level_color in
    let pp = styled (`Fg color) Logs.pp_header in
    pf ppf "%a" pp v
  in
  let pp_src ppf v =
    let pp = using Logs.Src.name (styled `Cyan string) in
    if not @@ Logs.Src.equal Logs.default v then pp ppf v
  in
  let pp_detail = option (styled `Green (fmt " (%s)")) in
  let report src lvl ~over k msgf =
    let ppf = stderr in
    let k _ppf = over (); k () in
    let with_detail h tags k user_fmt =
      let detail = Option.bind tags (Logs.Tag.find detail_tag) in
      let dt =
        Ptime.sub_span (Ptime_clock.now ()) time_anchor
        |> Option.get
        |> Ptime.to_float_s
      in
      let k ppf = kpf k ppf "%a@." pp_detail detail in
      let k ppf = kpf k ppf user_fmt in
      kpf k ppf "%a %a %a"
        (styled `Faint (styled (`Fg `White) (fmt "%04.02f")))
        dt pp_header (lvl, h) pp_src src
    in
    msgf @@ fun ?header ?tags fmt -> with_detail header tags k fmt
  in
  { report }

let () =
  Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ();
  Logs.set_reporter reporter;
  Logs.set_level ~all:false (Some Logs.Debug);
  Logs.Src.set_level Logs.default (Some Logs.Debug);
  Logs_threaded.enable ();
  Printexc.record_backtrace true;
  ()

let error_detail ?hint _status =
  let open Api in
  let code = -1 in
  let s = encode_exn ErrorDetail.jsont { code; hint } in
  s

module Respond_with = struct
  open Vif.Response
  open Syntax

  let bad_request ?hint req =
    let body = error_detail ?hint `Bad_request in
    let* () = with_string ?compression:None req body in
    respond `Bad_request

  let not_modified () =
    let* () = empty in
    respond `Not_modified

  let unsupported_media_type req =
    let body =
      error_detail ~hint:"no acceptable mimetype" `Unsupported_media_type
    in
    let* () = with_string ?compression:None req body in
    let* () = add ~field:"accept" Headers.accept_header_value in
    respond `Unsupported_media_type
end

(* TODO check for mathcing ETAG with a middleware instead? *)
(* /terms + /privacy
   - try to find a response with an acceptable mime-type
   - pick the version in the most preferred language of the user
   - apply compression if that is allowed by the client
   - set ETAG header
   - If it did not change, a "304 Not Modified" response will be returned
   - 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"),
     include a "Avail-Languages" header: a comma-separated list of the languages available *)
module Static = struct
  let f kind req _server _env =
    let etag = Assets.etag kind in
    let headers = Vif.Request.headers req in
    let has_matching_etag =
      match Vif.Headers.get headers "if-none-match" with
      | None -> Ok false
      | Some s ->
          Headers_lib.Etag.parse s
          |> Result.map (Headers_lib.Etag.evaluate etag)
    in
    match has_matching_etag with
    | Error e -> Respond_with.bad_request ~hint:e req
    | Ok true -> Respond_with.not_modified ()
    | Ok false -> (
        match Headers.select_mimetype headers with
        | None -> Respond_with.unsupported_media_type req
        | Some mime ->
            let lang = Headers.select_language headers in
            let compression = Headers.select_encoding headers in
            let data = Assets.get_content ~mime ~lang kind in
            (* -- *)
            let open Vif.Response in
            let open Syntax in
            let* () = with_string ?compression req data in
            let* () =
              let etag_field_value = Headers_lib.Etag.to_field_value etag in
              add ~field:"etag" etag_field_value
            in
            let* () =
              (* todo: is it "taler-privacy-version" for /policy ? *)
              add ~field:"taler-terms-version" Assets.terms_legal_version
            in
            let* () =
              add ~field:"avail-languages" Headers.avail_languages_header_value
            in
            let* () =
              let content_type = Fmt.str "%a" Assets.Mimetype.pp_mime mime in
              add ~field:"content-type" content_type
            in
            respond `OK)

  let terms = f Assets.Terms
  let privacy = f Assets.Privacy
end

let hello req _server _env =
  let open Vif.Response in
  let open Syntax in
  let* () = with_string req "Hello~~\n" in
  let* () = add ~field:"content-type" "text/plain" in
  respond `OK

let routes =
  let open Vif.Uri in
  let open Vif.Route in
  let open Vif.Type in
  [
    get (rel /?? nil) --> hello; get (rel / "terms" /?? nil) --> Static.terms;
    get (rel / "privacy" /?? nil) --> Static.privacy;
    get (rel / "management" / "keys" /?? nil) --> Management.keys_get;
    post any (rel / "management" / "keys" /?? nil) --> Management.keys_post;
  ]

let () =
  (*Logs.set_reporter (Logs_fmt.reporter ());*)
  let cfg =
    let port = Config.Exchange.port in
    let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, port)) in
    Vif.config sockaddr
  in
  Miou_unix.run @@ fun () ->
  Caqti_miou.Switch.run @@ fun caqti_switch ->
  let env : Devices.env =
    { caqti_switch; db_uri= Config.Exchangedb_postgres.config }
  in
  let devices =
    Vif.Devices.
      [ Devices.db_connection; Devices.secmod_signkey; Devices.secmod_denom ]
  in
  let middlewares = Vif.Middlewares.[] in
  Logs.info (fun m -> m ~tags:(detail "~~!") "Starting MTE server");
  Vif.run ~cfg ~devices ~middlewares routes env