lib/dune

@@ -0,0 +1,10 @@
+(library
+ (name include)
+ ; (wrapped false)
+ (modules taler_signatures)
+ (libraries))
+
+(library ; todo: should I have a /lib?
+ (name parse_config)
+ (modules parse_config)
+ (libraries mirage-crypto-ec ptime fmt angstrom uri amount b32))

lib/parse_config.ml

@@ -0,0 +1,276 @@
+(* parse config file
+   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_with msg =
+  Fmt.epr "Configuration failure: %s.@." msg;
+  exit 1
+
+let is_eol = function '\n' | '\r' -> true | _ -> false
+let is_whitespace = function ' ' | '\t' -> true | _ -> false
+let whitespace = skip_while is_whitespace
+
+module Parse_data = struct
+  type line =
+    | 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 take_till_end_of_line =
+    take_till is_eol >>= fun s -> return s <* end_of_line
+
+  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 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 s ->
+      match String.ends_with ~suffix:"\"" s with
+      | false -> fail_with "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
+      (whitespace *> char '=' *> whitespace *> item_value)
+    <* end_of_line
+
+  let config = many (choice [ blank; 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_with "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_with (Fmt.str "parse error `%s`" msg)
+    | 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
+  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_with (Fmt.str "expected integer, got `%s`" s)
+    | Some i -> return i
+
+  let duration_element =
+    let number = whitespace *> integer in
+    let dunit =
+      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
+      | "second" | "seconds" | "s" -> return `Second
+      | s -> fail_with (Fmt.str "expected a duration unit, got `%s`" s)
+    in
+    lift2 (fun number dunit -> { number; dunit }) number dunit
+
+  let duration = many1 duration_element <* end_of_input
+
+  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 ptime_span_of_int64 i =
+    match Ptime.Span.of_float_s (Int64.to_float i) with
+    | None ->
+        fail_with
+          (Fmt.str "ptime_span_of_int64 error: `%Ld` is not a valid ptime span"
+             i)
+    | Some ts -> ts
+
+  let to_ptime_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
+    let ptime = ptime_span_of_int64 acc in
+    ptime
+
+  let parse s : duration_element list =
+    match parse_string ~consume:All duration s with
+    | Error msg -> fail_with (Fmt.str "duration parse error `%s`" msg)
+    | Ok v -> v
+end
+
+let unwrap_res = function Error e -> fail_with (Fmt.str "`%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_with (Fmt.str "option `[%s].%s` not found" section field)
+  | Some v -> v
+
+let int s =
+  match int_of_string_opt s with
+  | None -> fail_with (Fmt.str "expected int value, got `%s`" s)
+  | Some v -> v
+
+let float s =
+  match float_of_string_opt s with
+  | None -> fail_with (Fmt.str "expected float value, got `%s`" s)
+  | Some v -> v
+
+let const_value a b =
+  match a = b with
+  | false -> fail_with (Fmt.str "unexpected value `%s`" b)
+  | true -> a
+
+let yes_no = function
+  | "NO" -> `NO
+  | "YES" -> `YES
+  | s -> fail_with (Fmt.str "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_ptime_span)
+
+let ed25519 s =
+  s
+  |> B32.decode
+  |> unwrap_res
+  |> Mirage_crypto_ec.Ed25519.pub_of_octets
+  |> Result.map_error (fun e -> Fmt.str "%a" Mirage_crypto_ec.pp_error e)
+  |> unwrap_res
+
+module Parse_alt_unit_names = struct
+  let rm_brackets s =
+    let s = String.trim s in
+    match
+      String.starts_with ~prefix:"{" s && String.ends_with ~suffix:"}" s
+    with
+    | false -> fail_with (Fmt.str "expected json, got `%s`" s)
+    | true ->
+        let s = String.sub s 1 (String.length s - 2) in
+        s
+
+  let rm_quotes s =
+    let s = String.trim s in
+    match
+      String.starts_with ~prefix:"\"" s && String.ends_with ~suffix:"\"" s
+    with
+    | false -> fail_with (Fmt.str "expected quoted string, got `%s`" s)
+    | true ->
+        let s = String.sub s 1 (String.length s - 2) in
+        s
+
+  let parse s =
+    let s = rm_brackets s in
+    String.split_on_char ',' s
+    |> List.map (String.split_on_char ':')
+    |> List.map (function
+      | [ k; v ] -> (k, v)
+      | _ -> fail_with "invalid json key-value map")
+    |> List.map (fun (k, v) ->
+        let k = rm_quotes k in
+        let v = rm_quotes v in
+        let k =
+          match int_of_string_opt k with
+          | None ->
+              fail_with
+                (Fmt.str
+                   "invalid json key-value map, expected integer key, got `%s`"
+                   k)
+          | Some k -> k
+        in
+        (k, v))
+end

lib/taler_signatures.ml

@@ -0,0 +1,78 @@
+(* 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