mte/src/parse_config.ml

(* rudimentary configuration file parser (INI-like)
   https://docs.taler.net/manpages/taler-exchange.conf.5.html

   do not support "$"-path expansion *)

open Angstrom

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

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

let fail fmt =
  let k _ppf = exit 1 in
  Fmt.kpf k Fmt.stderr ("Configuration failure: " ^^ fmt ^^ ".@.")

let is_eol = function '\n' | '\r' -> true | _ -> false
let is_whitespace = function ' ' | '\t' -> true | _ -> false
let blanks = skip_while is_whitespace

module Config_section = struct
  type t =
    | Blank
    | Comment of string
    | Header of string
    | Item of item

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

  let line = take_till is_eol <* end_of_line
  let blank_line = blanks <* end_of_line >>| fun () -> Blank
  let comment = blanks *> (char '#' <|> char '%') *> line >>| fun s -> Comment s

  let header =
    blanks *> char '[' *> id <* char ']' <* blanks <* end_of_line >>| fun s ->
    Header s

  let item_value =
    let unquoted_value =
      take_while1 (fun c -> not (is_whitespace c || is_eol c))
      <* blanks
      <* end_of_line
    in
    let quoted_value =
      char '"' *> take_till is_eol <* end_of_line >>= fun s ->
      match String.ends_with ~suffix:"\"" s && 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
      (blanks *> char '=' *> blanks *> item_value)

  let config =
    many (choice [ blank_line; 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 fail "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 ->
          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 -> fail "parse error `%s`" msg
    | Ok v -> fold_sections v
end

module Config_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 "expected integer, got `%s`" s
    | Some i -> return i

  let duration_element =
    let number = blanks *> integer in
    let dunit =
      blanks *> 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 "expected a duration unit, got `%s`" s
    in
    lift2 (fun number dunit -> { number; dunit }) number dunit

  let duration = many1 duration_element <* end_of_input

  (* TODO put this in Time.Relative *)
  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 to_time_span t =
    List.fold_left
      (fun acc { number; dunit } -> acc + (number * dunit_to_seconds dunit))
      0 t
    |> Int64.of_int
    |> Time.Relative.of_s

  let parse s : duration_element list =
    match parse_string ~consume:All duration s with
    | Error msg -> fail "duration parse error `%s`" msg
    | Ok v -> v
end

let unwrap = function Error e -> fail "`%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 "option `[%s].%s` not found" section field
  | Some v -> v

let int s =
  match int_of_string_opt s with
  | None -> fail "expected int value, got `%s`" s
  | Some v -> v

let float s =
  match float_of_string_opt s with
  | None -> fail "expected float value, got `%s`" s
  | Some v -> v

let const_value a b =
  match a = b with false -> fail "unexpected value `%s`" b | true -> a

let yes_no = function
  | "NO" -> `NO
  | "YES" -> `YES
  | s -> fail "expected `YES`/`NO` value, got `%s`" s

let uri s = Uri.of_string s
let amount s = s |> Amount.of_string |> unwrap
let duration s = Config_duration.(s |> parse |> to_time_span)

let ed25519 s =
  s
  |> B32.decode
  |> unwrap
  |> Mirage_crypto_ec.Ed25519.pub_of_octets
  |> Result.map_error (fun e -> Fmt.str "%a" Mirage_crypto_ec.pp_error e)
  |> unwrap

let etag s =
  match Headers_lib.Etag.parse s with
  | Ok etag -> etag
  | Error e -> (
      (* retry with quotes if needed *)
      match Headers_lib.Etag.parse (Fmt.str "\"%s\"" s) with
      | Ok etag -> etag
      | Error _ -> fail "could not parse etag `%s`: %s" s e)

(* TODO
   move to another module
   can we type the json as a Int_map directly? *)
module Alt_unit_names = struct
  open Syntax
  module String_map = Map.Make (String)

  let string_map_jsont = Jsont.Object.as_string_map Jsont.string

  let decode s =
    let* string_map = Jsont_bytesrw.decode_string string_map_jsont s in
    let l = String_map.to_list string_map in
    let* l =
      list_map
        (fun (k, v) ->
          match int_of_string_opt k with
          | None -> Error "alt_unit_names has a non-integer key"
          | Some k -> Ok (k, v))
        l
    in
    match List.find_opt (fun (i, _) -> i = 0) l with
    | None -> Error "alt_unit_names with no entry for base value \"0\""
    | Some _ -> Ok l

  let encode l =
    let l = List.map (fun (k, v) -> (string_of_int k, v)) l in
    let string_map = String_map.of_list l in
    let+ s = Jsont_bytesrw.encode_string string_map_jsont string_map in
    s

  let encode_exn l = encode l |> Result.get_ok
end