mte/include/parse_config.ml

(* 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

open Angstrom

type item = {
  key: string;
  value: string;
}

type section = {
  name: string;
  items: item list;
}

type config = section list

let is_whitespace = function ' ' | '\t' -> true | _ -> false
let whitespace = skip_while is_whitespace
let blank_line = whitespace *> end_of_line
let is_eol = function '\n' | '\r' -> true | _ -> false

let comment =
  whitespace *> peek_char >>= function
  | None -> fail "peek_char end_of_file failure"
  | Some c ->
      if c = '#' || c = '%' then
        skip_while (fun c -> not (is_eol c)) *> end_of_line
      else fail "not a comment"

let skip_ignored = skip_many (choice [ comment; blank_line ])

let identifier =
  let ident_char = function
    | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> true
    | _ -> false
  in
  take_while1 ident_char >>| String.lowercase_ascii

(* --- Values --- *)

let 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 line_rest ->
    match String.rindex_opt line_rest '"' with
    | None -> fail "unterminated quoted value"
    | Some i ->
        let value = String.sub line_rest 0 i in
        (* consume up to and including the closing quote *)
        let len = String.length line_rest in
        let remaining_len = len - i - 1 in
        advance (len - remaining_len) *> return value
  in
  whitespace *> (quoted_value <|> unquoted_value) <* skip_ignored

let item =
  lift2
    (fun key value -> { key; value })
    (identifier <* whitespace <* char '=')
    value

let section_header = char '[' *> identifier <* char ']'

let section =
  lift2
    (fun name items -> { name; items })
    (skip_ignored *> section_header)
    (many (skip_ignored *> item))

let config : config Angstrom.t =
  many_till (section <* skip_ignored) end_of_input

let parse_config s =
  match parse_string ~consume:Consume.All config s with
  | Ok v -> v
  | Error msg -> failwith msg

(* --- pp --- *)

let pp_item ppf { key; value } =
  let open Fmt in
  pf ppf "%s = %s" key value

let pp_section ppf (sec : section) =
  let open Fmt in
  pf ppf "[%s]@\n%a@." sec.name (list ~sep:(any "@\n") pp_item) sec.items

let pp_config ppf (cfg : config) =
  let open Fmt in
  pf ppf "%a@." (list ~sep:(any "@\n") pp_section) cfg

(* --- --- *)

let () =
  let content = read_file "default.config" in
  (*Fmt.pr "%s" content;*)

  let config = parse_config content in

  Fmt.pr "%a" pp_config config;

  ()