mte/include/parse_config.ml

(* parse config file
   https://docs.taler.net/manpages/taler-exchange.conf.5.html

   do not support "$"-path expansion*)

open Angstrom

type item = {
  key: string;
  value: string;
}

type section = {
  header: string;
  items: item list;
}

let fail_with msg =
  Fmt.epr "Failed to parse configuration: %s.@." msg;
  exit 1

let is_eol = function '\n' | '\r' -> true | _ -> false
let is_whitespace = function ' ' | '\t' -> true | _ -> false
let whitespace = skip_while is_whitespace

module Parse_file = struct
  type line =
    | Blank
    | Comment of string
    | Header of string
    | Item of item

  let id =
    let ident_char = function
      | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> true
      | _ -> false
    in
    take_while1 ident_char >>| String.lowercase_ascii

  let take_till_end_of_line =
    take_till is_eol >>= fun s -> return s <* end_of_line

  let blank = whitespace <* end_of_line >>| fun () -> Blank

  let comment =
    whitespace *> (char '#' <|> char '%') *> take_till_end_of_line >>| fun s ->
    Comment s

  let header = char '[' *> id <* char ']' <* end_of_line >>| fun s -> Header s

  let item_value =
    let unquoted_value =
      take_while1 (fun c -> not (is_whitespace c || is_eol c))
    in
    let quoted_value =
      char '"' *> take_till is_eol >>= fun s ->
      match String.ends_with ~suffix:"\"" s with
      | false -> fail_with "invalid quoted value"
      | true ->
          let value = String.sub s 0 (String.length s - 1) in
          return value
    in
    quoted_value <|> unquoted_value

  let item =
    lift2
      (fun key value -> Item { key; value })
      id
      (whitespace *> char '=' *> whitespace *> item_value)
    <* end_of_line

  let config = many (choice [ blank; comment; header; item ]) <* end_of_input

  let fold_sections l =
    let rec loop section_l item_l l =
      match l with
      | [] ->
          if List.is_empty item_l then section_l
          else fail_with "invalid configuration structure"
      | Blank :: tl | Comment _ :: tl -> loop section_l item_l tl
      | Item item :: tl -> loop section_l (item :: item_l) tl
      | Header header :: tl ->
          let section = { header; items= item_l } in
          loop (section :: section_l) [] tl
    in
    loop [] [] (List.rev l)

  let parse_content s =
    match parse_string ~consume:All config s with
    | Error msg -> fail_with (Fmt.str "parse error `%s`" msg)
    | Ok v -> fold_sections v
end

module Pp_debug = struct
  let pp_item ppf { key; value } =
    let open Fmt in
    match String.contains value '"' || String.contains value ' ' with
    | false -> pf ppf "%s = %s" key value
    | true -> pf ppf "%s = \"%s\"" key value

  let pp_line ppf line =
    let open Fmt in
    let open Parse_file in
    match line with
    | Blank -> Fmt.nop ppf ()
    | Comment s -> pf ppf "#%s" s
    | Header s -> pf ppf "[%s]" s
    | Item item -> pf ppf "%a" pp_item item

  let _pp_lines ppf raw_line_l =
    let open Fmt in
    pf ppf "%a" (list ~sep:(any "\n") pp_line) raw_line_l

  let pp_section ppf { header; items } =
    let open Fmt in
    pf ppf "[%s]@\n%a" header (list ~sep:(any "\n") pp_item) items

  let pp_config ppf l =
    let open Fmt in
    pf ppf "%a" (list ~sep:(any "\n") pp_section) l
end
[@@ocaml.warning "-32"]

module Parse_duration = struct
  type duration_element = {
    number: int;
    dunit: [ `Year | `Week | `Day | `Hour | `Minute | `Second ];
  }

  let integer =
    take_while1 (function '0' .. '9' -> true | _ -> false) >>= fun s ->
    match int_of_string_opt s with
    | None -> fail_with (Fmt.str "expected integer, got `%s`" s)
    | Some i -> return i

  let duration_element =
    let number = whitespace *> integer in
    let dunit =
      whitespace *> take_while1 (fun c -> not (is_whitespace c || is_eol c))
      >>= function
      | "year" | "years" -> return `Year
      | "week" | "weeks" -> return `Week
      | "day" | "days" -> return `Day
      | "hour" | "hours" -> return `Hour
      | "minute" | "minutes" -> return `Minute
      | "second" | "seconds" | "s" -> return `Second
      | s -> fail_with (Fmt.str "expected a duration unit, got `%s`" s)
    in
    lift2 (fun number dunit -> { number; dunit }) number dunit

  let duration = many1 duration_element <* end_of_input

  let dunit_to_seconds u =
    let rec f = function
      | `Year -> 365 * f `Day
      | `Week -> 7 * f `Day
      | `Day -> 24 * f `Hour
      | `Hour -> 60 * f `Minute
      | `Minute -> 60 * f `Second
      | `Second -> 1
    in
    f u

  let ptime_span_of_int64 i =
    match Ptime.Span.of_float_s (Int64.to_float i) with
    | None ->
        fail_with
          (Fmt.str "ptime_span_of_int64 error: `%Ld` is not a valid ptime span"
             i)
    | Some ts -> ts

  let to_ptime_span t =
    let acc =
      List.fold_left
        (fun acc { number; dunit } -> acc + (number * dunit_to_seconds dunit))
        0 t
    in
    let acc = Int64.of_int acc in
    let ptime = ptime_span_of_int64 acc in
    ptime

  let parse s : duration_element list =
    match parse_string ~consume:All duration s with
    | Error msg -> fail_with (Fmt.str "duration parse error `%s`" msg)
    | Ok v -> v
end

let unwrap_res = function Error e -> fail_with (Fmt.str "`%s`." e) | Ok v -> v

let get_opt t ~section ~field =
  match List.find_opt (fun v -> v.header = section) t with
  | None -> None
  | Some v -> (
      match List.find_opt (fun item -> item.key = field) v.items with
      | None -> None
      | Some item -> Some item.value)

let get t ~section ~field =
  match get_opt t ~section ~field with
  | None -> fail_with (Fmt.str "option `[%s].%s` not found" section field)
  | Some v -> v

let int s =
  match int_of_string_opt s with
  | None -> fail_with (Fmt.str "expected int value, got `%s`" s)
  | Some v -> v

let float s =
  match float_of_string_opt s with
  | None -> fail_with (Fmt.str "expected float value, got `%s`" s)
  | Some v -> v

let const_value a b =
  match a = b with
  | false -> fail_with (Fmt.str "unexpected value `%s`" b)
  | true -> a

let yes_no = function
  | "NO" -> `NO
  | "YES" -> `YES
  | s -> fail_with (Fmt.str "expected `YES`/`NO` value, got `%s`" s)

let uri s = Uri.of_string s
let amount s = s |> Amount.of_string |> unwrap_res
let duration s = Parse_duration.(s |> parse |> to_ptime_span)

let ed25519 s =
  s
  |> B32.decode
  |> unwrap_res
  |> Mirage_crypto_ec.Ed25519.pub_of_octets
  |> Result.map_error (fun e -> Fmt.str "%a" Mirage_crypto_ec.pp_error e)
  |> unwrap_res

module Parse_alt_unit_names = struct
  let rm_brackets s =
    let s = String.trim s in
    match
      String.starts_with ~prefix:"{" s && String.ends_with ~suffix:"}" s
    with
    | false -> fail_with (Fmt.str "expected json, got `%s`" s)
    | true ->
        let s = String.sub s 1 (String.length s - 2) in
        s

  let rm_quotes s =
    let s = String.trim s in
    match
      String.starts_with ~prefix:"\"" s && String.ends_with ~suffix:"\"" s
    with
    | false -> fail_with (Fmt.str "expected quoted string, got `%s`" s)
    | true ->
        let s = String.sub s 1 (String.length s - 2) in
        s

  let parse s =
    let s = rm_brackets s in
    String.split_on_char ',' s
    |> List.map (String.split_on_char ':')
    |> List.map (function
      | [ k; v ] -> (k, v)
      | _ -> fail_with "invalid json key-value map")
    |> List.map (fun (k, v) ->
        let k = rm_quotes k in
        let v = rm_quotes v in
        let k =
          match int_of_string_opt k with
          | None ->
              fail_with
                (Fmt.str
                   "invalid json key-value map, expected integer key, got `%s`"
                   k)
          | Some k -> k
        in
        (k, v))
end

module Config = struct
  [@@@ocaml.warning "-32-69"]

  let config =
    let read_file file = In_channel.with_open_bin file In_channel.input_all in
    let content = read_file "default.config" in
    let v = Parse_file.parse_content content in
    (*Fmt.epr "config file:@\n%a@." Pp_debug.pp_config v;*)
    v

  module Exchange = struct
    let get_opt field = get_opt config ~section:"exchange" ~field
    let get field = get config ~section:"exchange" ~field

    (* - *)
    let currency = (* todo: constraint on currency string *) get "currency"
    let currency_round_unit = get "currency_round_unit" |> amount
    let db = get "db" |> const_value "postgres"
    let attribute_encryption_key = get "attribute_encryption_key"
    let port = get "port" |> int
    let bind_to = get "bind_to"
    let master_public_key = get "master_public_key" |> ed25519
    let stefan_abs = get "stefan_abs" |> amount
    let stefan_log = get "stefan_log" |> amount
    let stefan_lin = get_opt "stefan_lin" |> Option.map float

    let aggregator_idle_sleep_interval =
      get "aggregator_idle_sleep_interval" |> duration

    let closer_idle_sleep_interval =
      get "closer_idle_sleep_interval" |> duration

    let transfer_idle_sleep_interval =
      get "transfer_idle_sleep_interval" |> duration

    let wirewatch_idle_sleep_interval =
      get "wirewatch_idle_sleep_interval" |> duration

    let signkey_legal_duration = get "signkey_legal_duration" |> duration
    let max_keys_caching = get "max_keys_caching" |> duration
    let enable_kyc = get "enable_kyc" |> yes_no
    let terms_etag = get "terms_etag"
    let privacy_etag = get "privacy_etag"

    (* optional:
       tiny_amount
       shopping_url
       open_banking_gateway_url
       aml_spa_dialect
       bank_compliance_language
       toplevel_redirect_url *)
    (* not implemented or not relevant to MTE:
       let max_requests = get "max_requests" |> int
       base_url
       aggregator_shard_size
       serve
       unixpath
       unixpath_mode
       terms_dir
       privacy_dir *)
  end

  module Exchangedb = struct
    let get field = get config ~section:"exchangedb" ~field

    (* - *)
    let idle_reserve_expiration_time =
      get "idle_reserve_expiration_time" |> duration

    let legal_reserve_expiration_time =
      get "legal_reserve_expiration_time" |> duration

    let aggregator_shift = get "aggregator_shift" |> duration
    let max_aml_program_runtime = get "max_aml_program_runtime" |> duration
    let default_purse_limit = get "default_purse_limit" |> int
  end

  module Exchangedb_postgres = struct
    let config =
      get config ~section:"exchangedb-postgres" ~field:"config" |> uri
  end

  module Currency = struct
    type t = {
      enabled: [ `YES | `NO ];
      code: string;
      name: string;
      fractional_input_digits: int;
      fractional_normal_digits: int;
      fractional_trailing_zero_digits: int;
      alt_unit_names: (int * string) list;
    }

    let currency_sections =
      List.filter
        (fun v -> String.starts_with ~prefix:"currency-" v.header)
        config

    let parse_currency section =
      let get field = get config ~section:section.header ~field in
      {
        enabled= get "enabled" |> yes_no;
        code= get "code";
        name= get "name";
        fractional_input_digits= get "fractional_input_digits" |> int;
        fractional_normal_digits= get "fractional_normal_digits" |> int;
        fractional_trailing_zero_digits=
          get "fractional_trailing_zero_digits" |> int;
        alt_unit_names= get "alt_unit_names" |> Parse_alt_unit_names.parse;
      }

    let all_currencies = List.map parse_currency currency_sections

    (* I think the exchange only handle one currency *)
    let v =
      match
        List.find_opt (fun v -> v.code = Exchange.currency) all_currencies
      with
      | None ->
          fail_with
            (Fmt.str
               "section `[currency-%s]` not found, currency `%s` is not defined"
               Exchange.currency Exchange.currency)
      | Some v -> v
  end

  module Coin = struct
    type t = {
      section_name: string;
      value: Amount.t;
      duration_withdraw: Ptime.Span.t;
      duration_spend: Ptime.Span.t;
      duration_legal: Ptime.Span.t;
      fee_withdraw: Amount.t;
      fee_deposit: Amount.t;
      fee_refresh: Amount.t;
      fee_refund: Amount.t;
      cipher: [ (* `CS |*) `RSA ];
      rsa_keysize: int; (* : int option (only if `RSA) *)
      age_restricted: [ (*`YES|*) `NO ];
    }

    let coin_sections =
      List.filter
        (fun v ->
          (* note: here its a '_' not '-' *)
          String.starts_with ~prefix:"coin_" v.header)
        config

    let parse_coin section =
      let get field = get config ~section:section.header ~field in
      let section_name =
        String.sub section.header 5 (String.length section.header - 5)
      in
      {
        section_name;
        value= get "value" |> amount;
        duration_withdraw= get "duration_withdraw" |> duration;
        duration_spend= get "duration_spend" |> duration;
        duration_legal= get "duration_legal" |> duration;
        fee_withdraw= get "fee_withdraw" |> amount;
        fee_deposit= get "fee_deposit" |> amount;
        fee_refresh= get "fee_refresh" |> amount;
        fee_refund= get "fee_refund" |> amount;
        cipher= (get "cipher" |> const_value "RSA" |> fun _s -> `RSA);
        rsa_keysize= get "rsa_keysize" |> int;
        age_restricted=
          ( get "age_restricted" |> yes_no |> function
            | `NO -> `NO
            | `YES -> fail_with "`age_restricted = YES` is not supported" );
      }

    let all_coins = List.map parse_coin coin_sections

    let get_coin name =
      match List.find_opt (fun v -> v.section_name = name) all_coins with
      | None ->
          fail_with
            (Fmt.str "section `[coin_%s]` not found, coin `%s` is not defined"
               name name)
      | Some v -> v

    let kudo_1 = get_coin "kudo_1"
    let kudo_2 = get_coin "kudo_2"
  end

  module Make_exchange_secmod (M : sig
    val kind : string
  end) : sig
    val lookahead_sign : Ptime.Span.t
    val overlap_duration : Ptime.Span.t
  end = struct
    let get field =
      let section = "taler-exchange-secmod-" ^ M.kind in
      get config ~section ~field

    let lookahead_sign = get "lookahead_sign" |> duration
    let overlap_duration = get "overlap_duration" |> duration
    (* not relevant:
     sm_priv_key
     key_dir
     unixpath *)
  end

  module Exchange_secmod_rsa = Make_exchange_secmod (struct
    let kind = "rsa"
  end)

  module Exchange_secmod_eddsa = Make_exchange_secmod (struct
    let kind = "eddsa"
  end)

  (* not implemented: module Exchange_secmod_cs *)
end