156 lines
4 KiB
OCaml
156 lines
4 KiB
OCaml
(* 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
|
|
|
|
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
|
|
|
|
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
|
|
|
|
let () =
|
|
let content = read_file "default.config" in
|
|
(*Fmt.pr "%s" content;*)
|
|
let config = parse content in
|
|
(*Fmt.pr "%a@." pp_lines config;*)
|
|
Fmt.pr "%a@." pp_config config;
|
|
|
|
()
|