generate taler_signatures.ml from GANA database

src/parse_config.ml

@@ -1,7 +1,7 @@
-(* parse config file
+(* rudimentary configuration file parser (INI-like)
    https://docs.taler.net/manpages/taler-exchange.conf.5.html
 
-   do not support "$"-path expansion*)
+   do not support "$"-path expansion *)
 
 open Angstrom
 
@@ -21,10 +21,10 @@ let fail fmt =
 
 let is_eol = function '\n' | '\r' -> true | _ -> false
 let is_whitespace = function ' ' | '\t' -> true | _ -> false
-let whitespace = skip_while is_whitespace
+let blanks = skip_while is_whitespace
 
-module Parse_data = struct
-  type line =
+module Config_section = struct
+  type t =
     | Blank
     | Comment of string
     | Header of string
@@ -37,24 +37,23 @@ module Parse_data = struct
     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 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 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 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 >>= fun s ->
-      match String.ends_with ~suffix:"\"" s with
+      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
@@ -66,10 +65,10 @@ module Parse_data = struct
     lift2
       (fun key value -> Item { key; value })
       id
-      (whitespace *> char '=' *> whitespace *> item_value)
-    <* end_of_line
+      (blanks *> char '=' *> blanks *> item_value)
 
-  let config = many (choice [ blank; comment; header; item ]) <* end_of_input
+  let config =
+    many (choice [ blank_line; comment; header; item ]) <* end_of_input
 
   let fold_sections l =
     let rec loop section_l item_l l =
@@ -91,37 +90,7 @@ module Parse_data = struct
     | Ok v -> fold_sections v
 end
 
-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
-    let open Parse_data 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
-[@@ocaml.warning "-32"]
-
-module Parse_duration = struct
+module Config_duration = struct
   type duration_element = {
     number: int;
     dunit: [ `Year | `Week | `Day | `Hour | `Minute | `Second ];
@@ -134,9 +103,9 @@ module Parse_duration = struct
     | Some i -> return i
 
   let duration_element =
-    let number = whitespace *> integer in
+    let number = blanks *> integer in
     let dunit =
-      whitespace *> take_while1 (fun c -> not (is_whitespace c || is_eol c))
+      blanks *> take_while1 (fun c -> not (is_whitespace c || is_eol c))
       >>= function
       | "year" | "years" -> return `Year
       | "week" | "weeks" -> return `Week
@@ -162,20 +131,12 @@ module Parse_duration = struct
     in
     f u
 
-  let ptime_span_of_int64 i =
-    match Ptime.Span.of_float_s (Int64.to_float i) with
-    | None ->
-        fail "ptime_span_of_int64 error: `%Ld` is not a valid ptime span" i
-    | Some ts -> ts
-
   let to_time_span t =
-    let acc =
-      List.fold_left
-        (fun acc { number; dunit } -> acc + (number * dunit_to_seconds dunit))
-        0 t
-    in
-    let acc = Int64.of_int acc in
-    Time.Relative.of_s acc
+    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
@@ -183,7 +144,7 @@ module Parse_duration = struct
     | Ok v -> v
 end
 
-let unwrap_res = function Error e -> fail "`%s`." e | Ok v -> v
+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
@@ -217,16 +178,16 @@ let yes_no = function
   | s -> fail "expected `YES`/`NO` value, got `%s`" s
 
 let uri s = Uri.of_string s
-let amount s = s |> Amount.of_string |> unwrap_res
-let duration s = Parse_duration.(s |> parse |> to_time_span)
+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_res
+  |> unwrap
   |> Mirage_crypto_ec.Ed25519.pub_of_octets
   |> Result.map_error (fun e -> Fmt.str "%a" Mirage_crypto_ec.pp_error e)
-  |> unwrap_res
+  |> unwrap
 
 (* TODO
    move to another module