diff --git a/default.config b/default.config new file mode 100644 index 00000000..7f586cae --- /dev/null +++ b/default.config @@ -0,0 +1,17 @@ +# comment 1 +# foo +# barr +[currency-EUR] +enabled = NO + # comment 2 +code= "EUR" +name =euro +fractional_input_digits = 2 +fractional_normal_digits =2 +fractional_trailing_zero_digits= 2 + % comment 3 +alt_unit_names = "{"0":"€","3":"k€"}" +% comment 4 + +[dummy-section] +dummy = "blah" diff --git a/include/dune b/include/dune index df2b6ee1..f5c8787a 100644 --- a/include/dune +++ b/include/dune @@ -9,6 +9,11 @@ (modules gen_taler_signatures) (libraries fmt angstrom)) +(executable + (name parse_config) + (modules parse_config) + (libraries fmt angstrom amount)) + ; 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 new file mode 100644 index 00000000..58d9bc4a --- /dev/null +++ b/include/parse_config.ml @@ -0,0 +1,160 @@ +(* parse config file + https://docs.taler.net/manpages/taler-exchange.conf.5.html + + do not support "$"-path expansion*) + +(* TODO + - integer + - duration + - YES|NO + - alt_unit_names json pair + +type duration_element = { + number: int; + unit_: [ `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_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 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 + | _ -> 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 "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 Fmt.failwith "invalid config 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 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; + + () diff --git a/include/taler_config_type.ml b/include/taler_config_type.ml index 117c0548..925e08b9 100644 --- a/include/taler_config_type.ml +++ b/include/taler_config_type.ml @@ -129,7 +129,7 @@ module type Coin = sig val fee_deposit : amount val fee_refresh : amount val fee_refund : amount - val cipher : [ `CS | `RSA ] + val cipher : [ (* `CS |*) `RSA ] val rsa_keysize : int option (*only if `RSA *) val age_restricted : [ (*`YES|*) `NO ] end