better parse_config

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

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:

include/parse_config.ml

@@ -4,63 +4,34 @@
    do not support "$"-path expansion*)
 
 (* TODO
-   - integer
+   - do all config section
-   - duration
+   - parse alt_unit_names json pair
-   - YES|NO
+   - better failure handling/error msg
-   - alt_unit_names json pair
+   *)
 
-type duration_element = {
+open Angstrom
-  number: int;
-  unit_: [ `Year | `Week | `Day | `Hour | `Minute | `Second ];
-}
 
-let integer =
+type item = {
-  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_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;
-  }
+}
 
+type section = {
+  header: string;
+  items: item list;
+}
+
+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,12 +87,13 @@ 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
+end
 
-  module Pp_debug = struct
+module Pp_debug = struct
   let pp_item ppf { key; value } =
     let open Fmt in
     match String.contains value '"' || String.contains value ' ' with
@@ -130,6 +102,7 @@ module Untyped = struct
 
   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
@@ -147,14 +120,195 @@ module Untyped = struct
   let pp_config ppf l =
     let open Fmt in
     pf ppf "%a" (list ~sep:(any "\n") pp_section) l
-  end
+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 () =
+let unwrap_res = function
-  let content = read_file "default.config" in
+  | Error e -> Fmt.failwith "Config failure: `%s`." e
-  (*Fmt.pr "%s" content;*)
+  | Ok v -> v
-  let config = Untyped.parse content in
-  (*Fmt.pr "%a@." pp_lines config;*)
-  Fmt.pr "%a@." Untyped.Pp_debug.pp_config config;
 
-  ()
+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

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 pp =
   let open Fmt in
-    let pp_sign ppf = function
+  let pp_sign ppf = function `Plus -> char ppf '+' | `Minus -> char ppf '-' in
-      | `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
+    pf ppf "%a%a:%Ld.%02ld" (Fmt.option pp_sign) sign pp_currency currency value
-        value fraction
+      fraction
-  in
+
-  Fmt.str "%a" pp
+let to_string = Fmt.str "%a" pp
 
 let of_string =
   let open Angstrom in