rename to lib/
This commit is contained in:
parent
a774ea11ac
commit
7748139d75
7 changed files with 12 additions and 13 deletions
90
lib/amount.ml
Normal file
90
lib/amount.ml
Normal file
|
|
@ -0,0 +1,90 @@
|
|||
(* TODO
|
||||
have safe amount arithmetic
|
||||
make type private
|
||||
redefine an Amount module with currency enforced to be Config.currency? *)
|
||||
(* Amounts of currency, serialized as `<Currency>:<IntegerPart>.<FractionalPart>`
|
||||
Fixed-precision numbers with 8 decimal places.
|
||||
- <Currency> must be at most 11 characters long
|
||||
only consist of ASCII letters (a-zA-Z).
|
||||
- integer part of <DecimalAmount> may be at most 2^52.
|
||||
- fractional part of <DecimalAmount> may contain at most 8 decimal digits.
|
||||
|
||||
Prefixed with '+' or '-' in certain contexts.
|
||||
When no sign is present, the amount is assumed to be positive. *)
|
||||
type sign =
|
||||
| Sign_plus
|
||||
| Sign_minus
|
||||
|
||||
type t = {
|
||||
sign: sign option;
|
||||
currency: string;
|
||||
value: Int64.t;
|
||||
fraction: Int32.t;
|
||||
}
|
||||
|
||||
let ( let* ) o f = match o with Ok v -> f v | Error _ as e -> e
|
||||
let check_not msg = function false -> Ok () | true -> Error msg
|
||||
let value_upper_bound = Z.(pow (of_int 2) 52) |> Z.to_int64
|
||||
let fraction_upper_bound = Int32.of_int 100_000_000
|
||||
|
||||
let make ~sign ~currency ~value ~fraction =
|
||||
let* () = check_not "value is negative" (value < Int64.zero) in
|
||||
let* () = check_not "fraction is negative" (fraction < Int32.zero) in
|
||||
let* () =
|
||||
check_not "value is greater than 2^52" (value > value_upper_bound)
|
||||
in
|
||||
let* () =
|
||||
check_not "fraction has more than 8 decimal digits"
|
||||
(fraction >= fraction_upper_bound)
|
||||
in
|
||||
Ok { sign; currency; value; fraction }
|
||||
|
||||
let pp =
|
||||
let open Fmt in
|
||||
let pp_sign ppf = function
|
||||
| Sign_plus -> char ppf '+'
|
||||
| Sign_minus -> char ppf '-'
|
||||
in
|
||||
fun ppf { sign; currency; value; fraction } ->
|
||||
pf ppf "%a%s:%Ld.%02ld" (Fmt.option pp_sign) sign currency value fraction
|
||||
|
||||
let to_string = Fmt.str "%a" pp
|
||||
|
||||
let of_string =
|
||||
let open Angstrom in
|
||||
let parse_sign =
|
||||
choice
|
||||
[
|
||||
char '+' *> return (Some Sign_plus);
|
||||
char '-' *> return (Some Sign_minus); return None;
|
||||
]
|
||||
in
|
||||
let parse_currency =
|
||||
(* TODO currency string constraint/format *)
|
||||
take_while1 (function
|
||||
| 'a' .. 'z' | 'A' .. 'Z' -> true
|
||||
| _ -> false)
|
||||
in
|
||||
let parse_int64 =
|
||||
take_while1 (function '0' .. '9' -> true | _ -> false)
|
||||
>>| Int64.of_string_opt
|
||||
>>= function
|
||||
| None -> fail "invalid integer"
|
||||
| Some n -> return n
|
||||
in
|
||||
let parse_int32 =
|
||||
take_while1 (function '0' .. '9' -> true | _ -> false)
|
||||
>>| Int32.of_string_opt
|
||||
>>= function
|
||||
| None -> fail "invalid integer"
|
||||
| Some n -> return n
|
||||
in
|
||||
let parse_t =
|
||||
lift4
|
||||
(fun sign currency value fraction ->
|
||||
make ~sign ~currency ~value ~fraction)
|
||||
parse_sign parse_currency
|
||||
(char ':' *> parse_int64)
|
||||
(char '.' *> parse_int32)
|
||||
in
|
||||
fun s -> parse_string ~consume:Consume.All parse_t s |> Result.join
|
||||
21
lib/amount.mli
Normal file
21
lib/amount.mli
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
type sign =
|
||||
| Sign_plus
|
||||
| Sign_minus
|
||||
|
||||
type t = private {
|
||||
sign: sign option;
|
||||
currency: string;
|
||||
value: Int64.t;
|
||||
fraction: Int32.t;
|
||||
}
|
||||
|
||||
val make :
|
||||
sign:sign option ->
|
||||
currency:string ->
|
||||
value:Int64.t ->
|
||||
fraction:Int32.t ->
|
||||
(t, string) result
|
||||
|
||||
val pp : Format.formatter -> t -> unit
|
||||
val to_string : t -> string
|
||||
val of_string : string -> (t, string) result
|
||||
28
lib/b32.ml
Normal file
28
lib/b32.ml
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
(* TODO test *)
|
||||
(* Crockford's variant of Base32
|
||||
http://www.crockford.com/wrmg/base32.html
|
||||
except that:
|
||||
- 'U' is not excluded but also decodes to 'V'
|
||||
- '-' is not allowed
|
||||
- checksum is not allowed *)
|
||||
|
||||
(* 'I' 'L' 'O' 'U' excluded *)
|
||||
type t = string
|
||||
|
||||
let alphabet = Base32.make_alphabet "0123456789ABCDEFGHJKMNPQRSTVWXYZ"
|
||||
let encode s = Base32.encode_string ~alphabet s
|
||||
|
||||
let decode s =
|
||||
let s =
|
||||
String.map
|
||||
(fun c ->
|
||||
match Char.uppercase_ascii c with
|
||||
| 'O' -> '0'
|
||||
| 'I' | 'L' -> '1'
|
||||
| 'U' -> 'V'
|
||||
| c -> c)
|
||||
s
|
||||
in
|
||||
match Base32.decode ~alphabet ~off:0 ~len:(String.length s) s with
|
||||
| Error (`Msg e) -> Error e
|
||||
| Ok v -> Ok v
|
||||
20
lib/dune
Normal file
20
lib/dune
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
(library
|
||||
(name include)
|
||||
; (wrapped false)
|
||||
(modules taler_signatures)
|
||||
(libraries))
|
||||
|
||||
(library
|
||||
(name parse_config)
|
||||
(modules parse_config)
|
||||
(libraries mirage-crypto-ec ptime fmt angstrom uri amount b32))
|
||||
|
||||
(library ; crockford base32
|
||||
(name b32)
|
||||
(modules b32)
|
||||
(libraries base32))
|
||||
|
||||
(library
|
||||
(name amount)
|
||||
(modules amount)
|
||||
(libraries angstrom fmt zarith))
|
||||
276
lib/parse_config.ml
Normal file
276
lib/parse_config.ml
Normal file
|
|
@ -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
|
||||
78
lib/taler_signatures.ml
Normal file
78
lib/taler_signatures.ml
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue