swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

JJ: Description from the destination commit:

Browse source 
better config: parse file + crunch

JJ: Description from source commit:
rm taler_config_type.ml
This commit is contained in:
swrup 2025-11-20 18:38:01 +01:00
parent e2d3986989
commit 26a1c0f835
12 changed files with 481 additions and 409 deletions
Download patch file Download diff file Expand all files Collapse all files

4
include/dune
View file

@ -14,10 +14,10 @@
(modules gen_eddsa_key)
(libraries fmt mirage-crypto-rng.unix mirage-crypto-ec b32))
(executable
(library ; todo: should I have a /lib?
(name parse_config)
(modules parse_config)
(libraries fmt angstrom amount))
(libraries mirage-crypto-ec ptime fmt angstrom uri amount b32))
; we prefer to generate taler_signatures.ml once,
; and commit it, for versionning:

284
include/parse_config.ml
View file

@ -3,64 +3,33 @@
do not support "$"-path expansion*)
(* TODO
- integer
- duration
- YES|NO
- alt_unit_names json pair
open Angstrom
type duration_element = {
number: int;
unit_: [ `Year | `Week | `Day | `Hour | `Minute | `Second ];
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 fail_with msg =
Fmt.epr "Configuration failure: %s.@." msg;
exit 1
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_data = 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
@ -86,7 +55,7 @@ module Untyped = struct
let quoted_value =
char '"' *> take_till is_eol >>= fun s ->
match String.ends_with ~suffix:"\"" s with
| false -> fail "invalid quoted value"
| false -> fail_with "invalid quoted value"
| true ->
let value = String.sub s 0 (String.length s - 1) in
return value
@ -107,7 +76,7 @@ module Untyped = struct
match l with
| [] ->
if List.is_empty item_l then section_l
else Fmt.failwith "invalid config structure"
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 ->
@ -118,43 +87,190 @@ module Untyped = struct
let parse s =
match parse_string ~consume:All config s with
| Error msg -> Fmt.failwith "config parse error: %s" msg
| Error msg -> fail_with (Fmt.str "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_data 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

175
include/taler_config_type.ml
View file

@ -1,175 +0,0 @@
(* https://docs.taler.net/manpages/taler-exchange.conf.5.html
taler-docs/manpages/taler-exchange.conf.5.rst *)
(* TODO
- generate `config.ml` from config file (virtual module)?
- parse config file format
- no relative path
- default config
- better types
- impl duration
*)
(* TODO unikernel *)
type dir_path
type file_path
(* TODO *)
(* Values that represent a time duration are represented as a series of one or more NUMBER UNIT pairs, e.g. 60 s, 4 weeks 1 day, 5 years 2 minutes. *)
type duration
(* TODO
make it Amount.t *)
type amount = string
type payto_uri = string
(* TODO
still need to parse them and tell that its not supported
some maybe are relevant
idk *)
type not_relevant
type url = string
type seconds = int
(* not relevant for mirage *)
(* this contains path that can be referenced in other with $PATH
(unsupported) *)
module type Global = sig
val taler_home : dir_path
val taler_data_home : dir_path
val taler_config_home : dir_path
val taler_cache_home : dir_path
val taler_runtime_dir : dir_path
end
(* sections "[currency-$NAME]"
see DD51 *)
module type Currency = sig
val enabled : [ `YES | `NO ]
val code : string
val name : string
val fractional_input_digits : int
val fractional_normal_digits : int
val fractional_trailing_zero_digits : int
val alt_unit_names : (int * string) list
end
(* section "[exchange]" *)
module type Exchange = sig
val currency : string
val currency_round_unit : amount
val db : string
val attribute_encryption_key : string
val serve : [ `Unix | `Tcp | `Systemd ]
val unixpath : file_path
val unixpath_mode : int
val port : int
val bind_to : string
val master_public_key : string
val tiny_amount : amount option
val shopping_url : url option
val open_banking_gateway_url : url option
val aml_spa_dialect : string option
val bank_compliance_language : string option
val stefan_abs : amount
val stefan_log : amount
val stefan_lin : float
val base_url : url
val toplevel_redirect_url : string option
val aggregator_idle_sleep_interval : seconds
val closer_idle_sleep_interval : seconds
val transfer_idle_sleep_interval : seconds
val wirewatch_idle_sleep_interval : seconds
val aggregator_shard_size : int option
val signkey_legal_duration : duration
val max_keys_caching : duration
val max_requests : int
val terms_dir : dir_path
val terms_etag : string
val privacy_dir : dir_path
val privacy_etag : string
val enable_kyc : [ `YES | `NO ]
end
(* section "[taler-exchange-secmod-{rsa|cs|eddsa}]". *)
module type Secmod = sig
val lookahead_sign : duration
val overlap_duration : duration
val sm_priv_key : file_path
val key_dir : dir_path
val unixpath : not_relevant
end
module type Secmod_rsa = Secmod
module type Secmod_cs = Secmod
module type Secmod_eddsa = Secmod
(* TODO config
what is the time/duration unit used here? *)
(* section "[exchangedb]". *)
module type Database = sig
val idle_reserve_expiration_time : seconds
val legal_reserve_expiration_time : seconds
val aggregator_shift : seconds
val default_purse_limit : int
val max_aml_program_runtime : int option
module type Postgres_backend = sig
val config : string
end
end
(* sections "[coin_XXX]"
used by secmods *)
module type Coin = sig
val value : amount
val duration_withdraw : duration
val duration_spend : duration
val duration_legal : duration
val fee_withdraw : amount
val fee_deposit : amount
val fee_refresh : amount
val fee_refund : amount
val cipher : [ (* `CS |*) `RSA ]
val rsa_keysize : int option (*only if `RSA *)
val age_restricted : [ (*`YES|*) `NO ]
end
(* sections "[exchange-account-XXX]" *)
module type Account = sig
val payto_uri : payto_uri
val enable_debit : [ `YES | `NO ]
val enable_credit : [ `YES | `NO ]
end
(* sections "[exchange-accountcredentials-XXX]"
must exists for each "[exchange-account-XXX]" section
! credentials to access the bank account
should be in a secret configuration file
only redable for `taler-exchange-wirewatch` `taler-exchange-transfer` processes *)
module type Account_secret = sig
val wire_gateway_url : url
val wire_gateway_auth_method : string
val username : string
val password : string
val token : string
end
(* section "[exchange-extension-<extensionname>]" *)
module type Extensions = sig
val enabled : [ (*`YES|*) `NO ]
end
(* section "[exchange-offline]". *)
module type Offline_signing = sig
val master_priv_file : file_path
(* TODO
- we need two different file here
- there is three, not two, crypto helper modules
is it only two, because the eddsa one is not comptabilized as a "crypto helper" here? *)
(* tofu = Trust On First Use *)
val secm_tofu_file : file_path
val secm_denom_pubkey : string option
val secm_esign_pubkey : string option
end