From 677681632a290280c6b8343c463e69da81ab413f Mon Sep 17 00:00:00 2001 From: swrup Date: Sun, 8 Feb 2026 03:50:01 +0100 Subject: [PATCH] generate taler_signatures.ml from GANA database --- include/dune | 5 - include/taler_signatures.ml | 78 --------- src/config.ml | 4 +- src/dune | 1 - src/parse_config.ml | 101 ++++------- src/signatures.ml | 1 - src/taler_signatures.ml | 280 +++++++++++++++++++++++++++++++ tools/dune | 6 +- tools/gen_signatures_registry.ml | 109 ++++++++++++ 9 files changed, 427 insertions(+), 158 deletions(-) delete mode 100644 include/dune delete mode 100644 include/taler_signatures.ml create mode 100644 src/taler_signatures.ml create mode 100644 tools/gen_signatures_registry.ml diff --git a/include/dune b/include/dune deleted file mode 100644 index 3418869c..00000000 --- a/include/dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name include) - ; (wrapped false) - (modules taler_signatures) - (libraries)) diff --git a/include/taler_signatures.ml b/include/taler_signatures.ml deleted file mode 100644 index d9211977..00000000 --- a/include/taler_signatures.ml +++ /dev/null @@ -1,78 +0,0 @@ -(* This file was generated by using data and/or code from the GNU Taler project, - under the AGPL-v3 licence. - Do not edit it. *) - -let master_aml_key : int32 = 1017_l -let master_drain_profit : int32 = 1018_l -let master_partner_details : int32 = 1019_l -let master_signing_key_revoked : int32 = 1020_l -let master_add_wire : int32 = 1021_l -let master_global_fees : int32 = 1022_l -let master_del_wire : int32 = 1023_l -let master_signing_key_validity : int32 = 1024_l -let master_denomination_key_validity : int32 = 1025_l -let master_add_auditor : int32 = 1026_l -let master_del_auditor : int32 = 1027_l -let master_wire_fees : int32 = 1028_l -let master_denomination_key_revoked : int32 = 1029_l -let master_wire_details : int32 = 1030_l -let master_extension : int32 = 1031_l -let exchange_reserve_status : int32 = 1032_l -let exchange_confirm_deposit : int32 = 1033_l -let exchange_confirm_melt : int32 = 1034_l -let exchange_key_set : int32 = 1035_l -let exchange_confirm_wire : int32 = 1036_l -let exchange_confirm_wire_deposit : int32 = 1037_l -let exchange_confirm_refund : int32 = 1038_l -let exchange_confirm_recoup : int32 = 1039_l -let exchange_reserve_closed : int32 = 1040_l -let exchange_confirm_recoup_refresh : int32 = 1041_l -let exchange_affirm_denom_unknown : int32 = 1042_l -let exchange_affirm_denom_expired : int32 = 1043_l -let exchange_confirm_purse_creation : int32 = 1045_l -let exchange_confirm_purse_merged : int32 = 1046_l -let exchange_purse_status : int32 = 1047_l -let exchange_reserve_attest_details : int32 = 1048_l -let exchange_confirm_purse_refund : int32 = 1049_l -let exchange_confirm_withdraw : int32 = 1050_l -let auditor_exchange_keys : int32 = 1064_l -let merchant_contract : int32 = 1101_l -let merchant_refund : int32 = 1102_l -let merchant_track_transaction : int32 = 1103_l -let merchant_payment_ok : int32 = 1104_l -let merchant_wire_details : int32 = 1107_l -let merchant_token_issue : int32 = 1108_l -let wallet_reserve_withdraw : int32 = 1200_l -let wallet_coin_deposit : int32 = 1201_l -let wallet_coin_melt : int32 = 1202_l -let wallet_coin_recoup : int32 = 1203_l -let wallet_coin_link : int32 = 1204_l -let wallet_account_setup : int32 = 1205_l -let wallet_coin_recoup_refresh : int32 = 1206_l -let wallet_age_attestation : int32 = 1207_l -let wallet_reserve_history : int32 = 1208_l -let wallet_coin_history : int32 = 1209_l -let wallet_purse_create : int32 = 1210_l -let wallet_purse_deposit : int32 = 1211_l -let wallet_purse_status : int32 = 1212_l -let wallet_purse_merge : int32 = 1213_l -let wallet_account_merge : int32 = 1214_l -let wallet_reserve_close : int32 = 1215_l -let wallet_purse_econtract : int32 = 1216_l -let wallet_reserve_open : int32 = 1217_l -let wallet_reserve_open_deposit : int32 = 1218_l -let wallet_reserve_attest_details : int32 = 1219_l -let wallet_purse_delete : int32 = 1220_l -let wallet_reserve_age_withdraw : int32 = 1221_l -let wallet_token_use : int32 = 1222_l -let mailbox_messages_delete : int32 = 1223_l -let sm_rsa_denomination_key : int32 = 1250_l -let sm_signing_key : int32 = 1251_l -let sm_cs_denomination_key : int32 = 1252_l -let client_test_eddsa : int32 = 1302_l -let exchange_test_eddsa : int32 = 1303_l -let aml_decision : int32 = 1350_l -let aml_query : int32 = 1351_l -let kyc_auth : int32 = 1360_l -let anastasis_policy_upload : int32 = 1400_l -let sync_backup_upload : int32 = 1450_l diff --git a/src/config.ml b/src/config.ml index 9be285c0..775e25c5 100644 --- a/src/config.ml +++ b/src/config.ml @@ -5,7 +5,7 @@ let config_data = match Assets_crunch.read path with | None -> fail "static file not found: `%s`" path | Some data -> - let v = Parse_data.parse data in + let v = Config_section.parse data in v module Exchange = struct @@ -109,7 +109,7 @@ module Currency = struct fractional_trailing_zero_digits= get "fractional_trailing_zero_digits" |> int; alt_unit_names= - get "alt_unit_names" |> Alt_unit_names.decode |> Parse_config.unwrap_res; + get "alt_unit_names" |> Alt_unit_names.decode |> Parse_config.unwrap; } let all_currencies = List.map parse_currency currency_sections diff --git a/src/dune b/src/dune index 2a1a266a..e9b61c38 100644 --- a/src/dune +++ b/src/dune @@ -10,7 +10,6 @@ (modules :standard \ mte b32) (libraries b32 - include ; caqti caqti-miou diff --git a/src/parse_config.ml b/src/parse_config.ml index cd2c141a..b93e0149 100644 --- a/src/parse_config.ml +++ b/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 diff --git a/src/signatures.ml b/src/signatures.ml index e3994695..4855835c 100644 --- a/src/signatures.ml +++ b/src/signatures.ml @@ -4,7 +4,6 @@ can we skip defining a specific record for signatures and directly use Api records? *) open Hash -module Taler_signatures = Include.Taler_signatures module Aliases = struct module Timestamp = struct diff --git a/src/taler_signatures.ml b/src/taler_signatures.ml new file mode 100644 index 00000000..8715b472 --- /dev/null +++ b/src/taler_signatures.ml @@ -0,0 +1,280 @@ +(* This file was generated from the GANA database: + https://git-www.gnunet.org/gana.git/tree/gnunet-signatures/registry.rec *) + +(** Initialize or update the status of an AML key for an AML officer *) +let master_aml_key : int32 = 1017_l + +(** Affirm wiring of exchange profits to operator account. *) +let master_drain_profit : int32 = 1018_l + +(** Signature affirming a partner configuration for wads. *) +let master_partner_details : int32 = 1019_l + +(** The given revocation key was revoked and must no longer be used. *) +let master_signing_key_revoked : int32 = 1020_l + +(** Add payto URI to the list of our wire methods. *) +let master_add_wire : int32 = 1021_l + +(** Signature over global set of fees charged by the exchange. *) +let master_global_fees : int32 = 1022_l + +(** Remove payto URI from the list of our wire methods. *) +let master_del_wire : int32 = 1023_l + +(** Purpose for signing public keys signed by the exchange master key. *) +let master_signing_key_validity : int32 = 1024_l + +(** Purpose for denomination keys signed by the exchange master key. *) +let master_denomination_key_validity : int32 = 1025_l + +(** Add an auditor to the list of our auditors. *) +let master_add_auditor : int32 = 1026_l + +(** Remove an auditor from the list of our auditors. *) +let master_del_auditor : int32 = 1027_l + +(** Fees charged per (aggregate) wire transfer to the merchant. *) +let master_wire_fees : int32 = 1028_l + +(** The given revocation key was revoked and must no longer be used. *) +let master_denomination_key_revoked : int32 = 1029_l + +(** Signature where the Exchange confirms its IBAN details in the /wire + response. *) +let master_wire_details : int32 = 1030_l + +(** Set the configuration of an extension (age-restriction or peer2peer) *) +let master_extension : int32 = 1031_l + +(** Purpose for the state of a reserve, signed by the exchange's signing key. *) +let exchange_reserve_status : int32 = 1032_l + +(** Signature where the Exchange confirms a deposit request. *) +let exchange_confirm_deposit : int32 = 1033_l + +(** Signature where the exchange (current signing key) confirms the no-reveal + index for cut-and-choose and the validity of the melted coins. *) +let exchange_confirm_melt : int32 = 1034_l + +(** Signature where the Exchange confirms the full /keys response set. *) +let exchange_key_set : int32 = 1035_l + +(** Signature where the Exchange confirms the /track/transaction response. *) +let exchange_confirm_wire : int32 = 1036_l + +(** Signature where the Exchange confirms the /wire/deposit response. *) +let exchange_confirm_wire_deposit : int32 = 1037_l + +(** Signature where the Exchange confirms a refund request. *) +let exchange_confirm_refund : int32 = 1038_l + +(** Signature where the Exchange confirms a recoup. *) +let exchange_confirm_recoup : int32 = 1039_l + +(** Signature where the Exchange confirms it closed a reserve. *) +let exchange_reserve_closed : int32 = 1040_l + +(** Signature where the Exchange confirms a recoup-refresh operation. *) +let exchange_confirm_recoup_refresh : int32 = 1041_l + +(** Signature where the Exchange confirms that it does not know a denomination + (hash). *) +let exchange_affirm_denom_unknown : int32 = 1042_l + +(** Signature where the Exchange confirms that it does not consider a + denomination valid for the given operation at this time. *) +let exchange_affirm_denom_expired : int32 = 1043_l + +(** Signature by which the exchange affirms that a purse was created with a + certain amount deposited into it. *) +let exchange_confirm_purse_creation : int32 = 1045_l + +(** Signature by which the exchange affirms that a purse was merged into a + reserve with a certain amount in it. *) +let exchange_confirm_purse_merged : int32 = 1046_l + +(** Purpose for the state of a purse, signed by the exchange's signing key. *) +let exchange_purse_status : int32 = 1047_l + +(** Signature by which the exchange attests identity attributes of a particular + reserve owner. *) +let exchange_reserve_attest_details : int32 = 1048_l + +(** Signature by which the exchange confirms that a purse expired and a coin was + refunded. *) +let exchange_confirm_purse_refund : int32 = 1049_l + +(** Signature where the Exchange confirms an (age-)withdraw. *) +let exchange_confirm_withdraw : int32 = 1050_l + +(** Signature where the auditor confirms that he is aware of certain + denomination keys from the exchange. *) +let auditor_exchange_keys : int32 = 1064_l + +(** Signature where the merchant confirms a contract (to the customer). *) +let merchant_contract : int32 = 1101_l + +(** Signature where the merchant confirms a refund (of a coin). *) +let merchant_refund : int32 = 1102_l + +(** Signature where the merchant confirms that he needs the wire transfer + identifier for a deposit operation. *) +let merchant_track_transaction : int32 = 1103_l + +(** Signature where the merchant confirms that the payment was successful *) +let merchant_payment_ok : int32 = 1104_l + +(** Signature where the merchant confirms its own (salted) wire details (not yet + really used). *) +let merchant_wire_details : int32 = 1107_l + +(** Signature where the merchant issues a token by blindly signing it. Signed + with the token issue private key. *) +let merchant_token_issue : int32 = 1108_l + +(** Signature where the reserve key confirms a withdraw request. Signed with the + reserve private key. *) +let wallet_reserve_withdraw : int32 = 1200_l + +(** Signature made by the wallet of a user to confirm a deposit of a coin. *) +let wallet_coin_deposit : int32 = 1201_l + +(** Signature using a coin key confirming the melting of a coin. Signed with the + coin's private key. *) +let wallet_coin_melt : int32 = 1202_l + +(** Signature using a coin key requesting recoup. Signed with the coin's private + key. *) +let wallet_coin_recoup : int32 = 1203_l + +(** Signature using a coin key authenticating link data. Signed with the old + coin's private key. *) +let wallet_coin_link : int32 = 1204_l + +(** Signature using a reserve key by which a wallet requests a payment target + UUID for itself. Signs over just a purpose (no body), as the signature only + serves to demonstrate that the request comes from the wallet controlling the + private key, and not some third party. *) +let wallet_account_setup : int32 = 1205_l + +(** Signature using a coin key requesting recoup-refresh. Signed with the coin + private key. *) +let wallet_coin_recoup_refresh : int32 = 1206_l + +(** Signature using a age restriction key for attestation of a particular + age/age-group. *) +let wallet_age_attestation : int32 = 1207_l + +(** Request full or partial reserve history. Signed with the reserve private + key. *) +let wallet_reserve_history : int32 = 1208_l + +(** Request full or partial coin history. Signed with the coin private key. *) +let wallet_coin_history : int32 = 1209_l + +(** Request purse creation (without reserve). Signed by the purse private key. +*) +let wallet_purse_create : int32 = 1210_l + +(** Request coin to be deposited into a purse. Signed with the coin private key. +*) +let wallet_purse_deposit : int32 = 1211_l + +(** Request purse status. Signed with the purse private key. *) +let wallet_purse_status : int32 = 1212_l + +(** Request purse to be merged with a reserve. Signed with the purse private + key. *) +let wallet_purse_merge : int32 = 1213_l + +(** Request purse to be merged with a reserve. Signed by the reserve private + key. *) +let wallet_account_merge : int32 = 1214_l + +(** Request account to be closed. Signed with the reserve private key. *) +let wallet_reserve_close : int32 = 1215_l + +(** Associates encrypted contract with a purse. Signed with the purse private + key. *) +let wallet_purse_econtract : int32 = 1216_l + +(** Request reserve to be kept open. Signed with the reserve private key. *) +let wallet_reserve_open : int32 = 1217_l + +(** Request coin to be used to pay for reserve to be kept open. Signed with the + coin private key. *) +let wallet_reserve_open_deposit : int32 = 1218_l + +(** Request attestation about reserve owner. Signed by the reserve private key. +*) +let wallet_reserve_attest_details : int32 = 1219_l + +(** Signature by which a wallet requests a purse to be deleted. *) +let wallet_purse_delete : int32 = 1220_l + +(** Signature where the reserve key confirms an age-withdraw request. Signed + with the reserve private key. *) +let wallet_reserve_age_withdraw : int32 = 1221_l + +(** Signature where the token use key confirms the usage of a token on a pay + request. Signed with the token use private key. *) +let wallet_token_use : int32 = 1222_l + +(** Signature used to unclaim an order, allowing other wallets to claim it. + Signed with the private key of the claim nonce. *) +let wallet_order_unclaim : int32 = 1223_l + +(** Signature on a denomination key announcement. *) +let sm_rsa_denomination_key : int32 = 1250_l + +(** Signature on an exchange message signing key announcement. *) +let sm_signing_key : int32 = 1251_l + +(** Signature on a denomination key announcement. *) +let sm_cs_denomination_key : int32 = 1252_l + +(** EdDSA test signature. *) +let client_test_eddsa : int32 = 1302_l + +(** EdDSA test signature. *) +let exchange_test_eddsa : int32 = 1303_l + +(** Signature by which an AML officer signs an AML decision. *) +let aml_decision : int32 = 1350_l + +(** Signature by which an AML officer requests AML data. *) +let aml_query : int32 = 1351_l + +(** Signature by which an account owner authorizes access to a KYC operation. *) +let kyc_auth : int32 = 1360_l + +(** EdDSA signature for a policy upload. *) +let anastasis_policy_upload : int32 = 1400_l + +(** EdDSA signature for a backup upload. *) +let sync_backup_upload : int32 = 1450_l + +(** The signature is done by the Donau. The Donau signes over the total amount + of the corresponding year, the corresponding year and the donation + identifier of a specific donor. The statement confirms that the donor made + this total in donations for the given year. *) +let donau_donation_statement : int32 = 1500_l + +(** The signature is made by a charity and shows that the charity is in + agreement with the donation request which it sends to the Donau. The charity + signs over all blinded identifiers and key pairs which it has received from + the donor. The signature affirms that the charity wants the donation + receipts to be issued on its behalf. *) +let charity_donation_confirmation : int32 = 1501_l + +(** The signature is made by a charity to request information about its status + from a Donau. It is not over anything in particular and is just there for + access control. *) +let charity_get_info : int32 = 1502_l + +(** Signature over messages to delete in the mailbox service *) +let mailbox_messages_delete : int32 = 1551_l + +(** Signature for mailbox registration request *) +let mailbox_register : int32 = 1552_l diff --git a/tools/dune b/tools/dune index f500902e..906889a7 100644 --- a/tools/dune +++ b/tools/dune @@ -4,4 +4,8 @@ (modules offline offline_impl offline_sig) (libraries cmdliner bos fmt mirage-crypto ptime mte vif)) -; todo depends on curl +(executable + (public_name gen_signatures_registry) + (name gen_signatures_registry) + (modules gen_signatures_registry) + (libraries angstrom bos fmt)) diff --git a/tools/gen_signatures_registry.ml b/tools/gen_signatures_registry.ml new file mode 100644 index 00000000..3d3a4191 --- /dev/null +++ b/tools/gen_signatures_registry.ml @@ -0,0 +1,109 @@ +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 url = + "https://git-www.gnunet.org/gana.git/plain/gnunet-signatures/registry.rec" + +let registry_file = "registry.rec" + +let download () = + let open Bos in + let res = + OS.Cmd.run Cmd.(v "curl" % "-s" % "-o" % registry_file % "-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 () = + download (); + let content = read_file registry_file in + match Recfile.parse content with + | Error msg -> Fmt.failwith "Recfile parse error: %s" msg + | Ok records -> + let purposes = parse_purposes records in + 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; + ()