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 hello req _server _env =
  let open Vifu.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 Vifu.Uri in
  let open Vifu.Route in
  let get path = get (path /?? any) in
  let post path jsont = post (Vifu.Type.json_encoding jsont) (path /?? any) in
  let v s = rel / s in
  let tos =
    [
      get rel --> hello;
      get (v "terms") --> Mte_terms.terms;
      get (v "privacy") --> Mte_terms.privacy;
    ]
  in
  let status_info =
    [
      get (v "seed") --> Mte_info.seed;
      get (v "config") --> Mte_info.config;
      get (v "keys") --> Mte_info.keys;
    ]
  in
  let management =
    let open Mte_management in
    let v s = v "management" / s in
    [
      get (v "keys") --> Keys_get.f;
      post (v "keys") Keys_post.jsont --> Keys_post.f;
      post (v "denominations" /% string `Path / "revoke") Denom_revoke.jsont
      --> Denom_revoke.f;
      post (v "signkeys" /% string `Path / "revoke") Signkey_revoke.jsont
      --> Signkey_revoke.f;
      post (v "auditors") Auditors.jsont --> Auditors.f;
      post (v "auditors" /% string `Path / "disable") Auditors_disable.jsont
      --> Auditors_disable.f;
      post (v "wire-fee") Wire_fee.jsont --> Wire_fee.f;
      post (v "global-fees") Global_fees.jsont --> Global_fees.f;
      post (v "wire") Wire.jsont --> Wire.f;
      post (v "wire" / "disable") Wire_disable.jsont --> Wire_disable.f;
      post (v "drain") Drain.jsont --> Drain.f;
      post (v "aml-officers") AmlOfficer.jsont --> AmlOfficer.f;
      post (v "partners") Partners.jsont --> Partners.f;
    ]
  in
  tos @ status_info @ management

module RNG = Mirage_crypto_rng.Fortuna

let () =
  let ( let@ ) finally fn = Fun.protect ~finally fn in
  Util.Log_reporter.setup ();
  let rng =
    let rng () = Mirage_crypto_rng_mkernel.initialize (module RNG) in
    Mkernel.map rng Mkernel.[]
  in
  let storage = Mkernel.storage ~name:"storage" in
  let service =
    let ipv4 = Ipaddr.V4.Prefix.of_string_exn "10.0.0.2/24" in
    Mnet.stack ~name:"service" ipv4
  in
  Mkernel.(run [ rng; storage; service ])
  @@ fun rng storage (stack, tcp, udp) () ->
  let@ () = fun () -> Mirage_crypto_rng_mkernel.kill rng in
  let@ () = fun () -> Mnet.kill stack in
  let hed, he = Mnet_happy_eyeballs.create tcp in
  let@ () = fun () -> Mnet_happy_eyeballs.kill hed in
  let dns = Mnet_dns.create (udp, he) in
  let t = Mnet_dns.transport dns in
  let@ () = fun () -> Mnet_dns.Transport.kill t in
  (* -- *)
  Caqti_miou.Switch.run @@ fun sw ->
  let db_conn =
    let db_uri = Config.Exchangedb_postgres.config in
    (* IMPROVE: use caqti pool
       [connect_pool] with parameter [?post_connect] for preflight *)
    match Caqti_mnet.connect ~sw stack tcp dns db_uri with
    | Error err ->
        Fmt.failwith "Database connection failure: %a." Caqti_error.pp err
    | Ok conn -> conn
  in
  let@ () =
   fun () ->
    let (module Conn : Pg.CONN) = db_conn in
    Conn.disconnect ()
  in
  let () = Pg.preflight db_conn in
  Logs.info (fun m -> m "database connection initialized");
  (* -- *)
  let keys : (module Keys.S) =
    let (module Conn : Pg.CONN) = db_conn in
    let (module Fs : Fat.FS) =
      (module struct
        let t = storage
      end)
    in
    (module Keys.Make (Conn) (Fs))
  in
  (* -- *)
  let cfg = Vifu.Config.v Config.Exchange.port in
  Vifu.run ~cfg tcp routes (db_conn, keys)

(*
  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 = Vifu.Devices.[ Devices.db_connection; Devices.keys ] in
  let middlewares = Vifu.Middlewares.[] in
  Logs.info (fun m ->
      m ~tags:(Util.Log_reporter.detail "...") "Starting MTE server");
  Vifu.run ~cfg ~devices ~middlewares routes env
  *)