From 3d8fb91c75a072da05dc188dd76256dbb029eca2 Mon Sep 17 00:00:00 2001 From: swrup Date: Thu, 20 Nov 2025 18:38:01 +0100 Subject: [PATCH] --- default.config | 26 ++++ include/dune | 2 +- include/parse_config.ml | 318 +++++++++++++++++++++++++++++----------- src/amount.ml | 22 ++- 4 files changed, 272 insertions(+), 96 deletions(-) diff --git a/default.config b/default.config index 7f586cae..99fdbdfb 100644 --- a/default.config +++ b/default.config @@ -15,3 +15,29 @@ alt_unit_names = "{"0":"€","3":"k€"}" [dummy-section] dummy = "blah" + +[exchange] +currency = EUR +currency_round_unit = EUR:0.01 +db = postgres +attribute_encryption_key = "deadbeef" +port = 3434 +bind_to = localhost +master_public_key = "8MQF2XPWCKCW4199JFPE08X7Y9XAX21SF2HD8NZKXM3PY3CMCJ90====" +stefan_abs = EUR:0.00 +stefan_log = EUR:0.00 +stefan_lin = 0.00 +aggregator_idle_sleep_interval = "1 hour" +closer_idle_sleep_interval = "1 hour" +transfer_idle_sleep_interval = "1 hour" +wirewatch_idle_sleep_interval = "1 hour" +signkey_legal_duration = "1 year" +max_keys_caching = "4 weeks" +enable_kyc = NO + +[exchangedb] +idle_reserve_expiration_time = "1 year 2 weeks 3 hours 4 minutes 5 seconds" +legal_reserve_expiration_time = "1 year" +aggregator_shift = "1 year" +max_aml_program_runtime = "1 year" +default_purse_limit = 9999 diff --git a/include/dune b/include/dune index d9601600..0bb76a72 100644 --- a/include/dune +++ b/include/dune @@ -17,7 +17,7 @@ (executable (name parse_config) (modules parse_config) - (libraries fmt angstrom amount)) + (libraries mirage-crypto-ec ptime fmt angstrom amount b32)) ; we prefer to generate taler_signatures.ml once, ; and commit it, for versionning: diff --git a/include/parse_config.ml b/include/parse_config.ml index 58d9bc4a..59ab359b 100644 --- a/include/parse_config.ml +++ b/include/parse_config.ml @@ -4,63 +4,34 @@ do not support "$"-path expansion*) (* TODO - - integer - - duration - - YES|NO - - alt_unit_names json pair + - do all config section + - parse alt_unit_names json pair + - better failure handling/error msg + *) -type duration_element = { - number: int; - unit_: [ `Year | `Week | `Day | `Hour | `Minute | `Second ]; +open Angstrom + +type item = { + key: string; + value: string; } -let integer = - take_while1 (function '0' .. '9' -> true | _ -> false) >>= fun s -> - match int_of_string_opt s with - | None -> fail "not an integer" - | Some i -> return i +type section = { + header: string; + items: item list; +} -let duration_value = - let number = whitespace *> integer in - let unit = - 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 - | "s" -> return `Second - | _ -> fail "not a valid duration unit" - in - many1 (lift2 (fun number unit_ -> { number; unit_ }) number unit) -*) - -let read_file file = In_channel.with_open_bin file In_channel.input_all - -module Untyped = struct - type item = { - key: string; - value: string; - } +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 - type section = { - header: string; - items: item list; - } - - open Angstrom - - let is_eol = function '\n' | '\r' -> true | _ -> false - let is_whitespace = function ' ' | '\t' -> true | _ -> false - let whitespace = skip_while is_whitespace - let id = let ident_char = function | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> true @@ -116,45 +87,228 @@ module Untyped = struct in loop [] [] (List.rev l) - let parse s = + let parse_content s = match parse_string ~consume:All config s with | Error msg -> Fmt.failwith "config parse error: %s" msg | Ok v -> fold_sections v - - 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 - 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 end -let () = - let content = read_file "default.config" in - (*Fmt.pr "%s" content;*) - let config = Untyped.parse content in - (*Fmt.pr "%a@." pp_lines config;*) - Fmt.pr "%a@." Untyped.Pp_debug.pp_config config; +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 "not an integer" + | 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 + | _ -> fail "not a valid duration unit" + 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 -> + Fmt.failwith + "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 -> Fmt.failwith "duration parse error: %s" msg + | Ok v -> v +end + +let unwrap_res = function + | Error e -> Fmt.failwith "Config failure: `%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 -> + Fmt.failwith "Config failure, option `[%s].%s` not found." section field + | Some v -> v + +let int v = + match int_of_string_opt v with + | None -> Fmt.failwith "expected int value, got `%s`." v + | Some v -> v + +let float v = + match float_of_string_opt v with + | None -> Fmt.failwith "expected float value, got `%s`." v + | Some v -> v + +let const_value a b = + match a = b with + | false -> Fmt.failwith "unexpected value `%s`." b + | true -> a + +let yes_no = function + | "NO" -> `NO + | "YES" -> `YES + | s -> Fmt.failwith "invalid value `%s`, expected `NO` or `YES`." s + +let amount v = v |> Amount.of_string |> unwrap_res +let duration v = Parse_duration.(v |> parse |> to_ptime_span) + +let ed25519 v = + v + |> 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 Config = struct + [@@@ocaml.warning "-32"] + + 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.pr "config file:@\n%a@." Pp_debug.pp_config v;*) + v + + 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 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 + + (* 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 + terms_etag + privacy_dir + privacy_etag *) + end +end diff --git a/src/amount.ml b/src/amount.ml index 5123ac37..9640642c 100644 --- a/src/amount.ml +++ b/src/amount.ml @@ -35,19 +35,15 @@ let make ~sign ~currency ~value ~fraction = in Ok { sign; currency; value; fraction } -let to_string = - let pp = - let open Fmt in - let pp_sign ppf = function - | `Plus -> char ppf '+' - | `Minus -> char ppf '-' - in - let pp_currency ppf = function `Eur -> string ppf "EUR" in - fun ppf { sign; currency; value; fraction } -> - pf ppf "%a%a:%Ld.%02ld" (Fmt.option pp_sign) sign pp_currency currency - value fraction - in - Fmt.str "%a" pp +let pp = + let open Fmt in + let pp_sign ppf = function `Plus -> char ppf '+' | `Minus -> char ppf '-' in + let pp_currency ppf = function `Eur -> string ppf "EUR" in + fun ppf { sign; currency; value; fraction } -> + pf ppf "%a%a:%Ld.%02ld" (Fmt.option pp_sign) sign pp_currency currency value + fraction + +let to_string = Fmt.str "%a" pp let of_string = let open Angstrom in