mte/tools/gen_taler_signatures.ml

module Recfile = struct
  (* rudimentary recfile parser
     https://www.gnu.org/software/recutils/manual/recutils.html#The-Rec-Format *)
  open Angstrom

  type field = {
    k: string;
    v: string;
  }

  type record = field list

  let newline = char '\n'
  let is_newline = function '\n' -> true | _ -> false

  let field_name =
    let first_char =
      satisfy (function 'a' .. 'z' | 'A' .. 'Z' | '%' -> true | _ -> false)
    in
    let subsequent_char =
      satisfy (function
        | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> true
        | _ -> false)
    in
    lift2
      (fun hd tl -> String.of_seq (List.to_seq (hd :: tl)))
      first_char (many subsequent_char)

  (* todo handle '\' escape and '+' on next line *)
  let field_value = take_till is_newline <* newline

  let field =
    let blank = satisfy (function ' ' | '\t' -> true | _ -> false) in
    let blanks = skip_many1 blank in
    lift3 (fun k () v -> { k; v }) field_name (char ':' *> blanks) field_value

  let blank = newline *> return ()
  let comment = (char '#' *> take_till is_newline <* newline) *> return ()
  let record = many1 field

  let records =
    let sep =
      (* at least one blank line *)
      skip_many comment *> blank *> skip_many (comment <|> blank)
    in
    sep_by1 sep record

  let recfile : record list t =
    skip_many (comment <|> blank) *> records <* skip_many (comment <|> blank)

  let parse s = parse_string ~consume:All recfile s
end

let download ~output ~url =
  let open Bos in
  let res =
    OS.Cmd.run
      Cmd.(
        v "curl"
        % "--silent"
        % "--show-error"
        % "-o"
        % output
        % "-X"
        % "GET"
        % url)
  in
  match res with
  | Error (`Msg s) -> Fmt.failwith "download failure: %s" s
  | Ok () -> ()

let read_file file = In_channel.with_open_bin file In_channel.input_all

type purpose = {
  number: int32;
  name: string;
  comment: string;
}

let parse_purposes records =
  records
  |> List.filter_map (fun l ->
      match l with
      | a :: b :: c :: _ -> (
          let open Recfile in
          match a.k = "Number" && b.k = "Name" && c.k = "Comment" with
          | false -> None
          | true ->
              Some
                {
                  number= Int32.of_int (int_of_string a.v);
                  name= String.lowercase_ascii b.v;
                  comment= c.v;
                })
      | _ -> None)
  |> List.filter (fun v -> v.number >= 1000_l)

let print_module purposes =
  let header =
    {|(* This file was generated from the GANA database:
   https://git-www.gnunet.org/gana.git/tree/gnunet-signatures/registry.rec *)|}
  in
  let pp ppf { number; name; comment } =
    Fmt.pf ppf "(** %s *)\nlet %s : int32 = %ld_l\n\n" comment name number
  in
  Fmt.pr "%s\n\n%a@." header (Fmt.list ~sep:Fmt.nop pp) purposes;
  ()

let url =
  "https://git-www.gnunet.org/gana.git/plain/gnunet-signatures/registry.rec"

(* tmp file *)
let registry_file = "registry.rec"

let main () =
  download ~output:registry_file ~url;
  let content = read_file registry_file in
  match Recfile.parse content with
  | Error msg -> Fmt.failwith "Recfile parse error: %s" msg
  | Ok records ->
      print_module (parse_purposes records);
      ()

let () = main ()