better parse_config
This commit is contained in:
parent
e2d3986989
commit
f55a6eb4a5
4 changed files with 272 additions and 96 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue