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 line =
  | Blank
  | Comment of string
  | Section_header of string
  | Item of item

let is_whitespace = function ' ' | '\t' -> true | _ -> false
let whitespace = skip_while is_whitespace
let is_eol = function '\n' | '\r' -> true | _ -> false
let blank = whitespace >>= fun () -> return Blank

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

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

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 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)

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

let section_header =
  char '[' *> item_key <* char ']' >>= fun s -> return (Section_header s)

let lines =
  let line = choice [ blank; comment; section_header; item ] <* end_of_line in
  many line <* end_of_input

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

let pp_line ppf line =
  let open Fmt in
  match line with
  | Blank -> Fmt.nop ppf ()
  | Comment s -> pf ppf "#%s" s
  | Section_header s -> pf ppf "[%s]" s
  | Item { key; value } -> pf ppf "%s = %s" key value

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

(* --- --- *)

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

  let config = parse content in

  Fmt.pr "%a@." pp_config config;

  ()
  *)
*)

(* --- ff --- *)
open Angstrom

let read_file file = In_channel.with_open_bin file In_channel.input_all

let raw_line =
  take_till (function '\n' | '\r' -> true | _ -> false) >>= fun s ->
  return s <* end_of_line

let raw_line_l = many raw_line <* end_of_input

let pp_raw_line ppf raw_line =
  let open Fmt in
  pf ppf "%s" raw_line

let pp ppf raw_line_l =
  let open Fmt in
  pf ppf "%a" (list ~sep:(any "\n") pp_raw_line) raw_line_l

(* Helper: parse whole input into list of lines *)
let parse s =
  match parse_string ~consume:All raw_line_l s with
  | Ok ls -> ls
  | Error msg -> failwith ("lines parse error: " ^ msg)

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

  let config = parse content in

  Fmt.pr "%a@." pp config;

  ()