rename to lib/

lib/amount.ml

@@ -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

lib/amount.mli

@@ -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

lib/b32.ml

@@ -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

lib/dune

@@ -0,0 +1,25 @@
+(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))
+
+(library
+ (name headers_lib)
+ (modules headers_lib)
+ (libraries angstrom fmt))

lib/headers_lib.ml

@@ -0,0 +1,86 @@
+(* independent library for headers fields value *)
+
+(* TODO - test - can still bypass this module and directly set Etag header, but
+   its fine *)
+module Etag : sig
+  (* module to parse etags header fields used by If-Match and If-None-Match
+     headers
+
+     https://httpwg.org/specs/rfc9110.html#field.etag *)
+  type t
+  type header_value
+
+  val parse : string -> (header_value, string) result
+  val of_crockford32 : string -> (t, string) result
+  val to_raw_string : t -> string
+  val to_field_value : t -> string
+  val evaluate : t -> header_value -> bool
+end = struct
+  (* raw etag *)
+  type t = string
+
+  (* type for the value of header field *)
+  type header_etag_item = {
+    weak: bool;
+    value: string;
+  }
+
+  type header_value =
+    | Any_etag
+    | Etag_list of header_etag_item list
+
+  let pp_header_etag_item ppf { weak; value } =
+    if weak then Fmt.pf ppf {|W/"%s"|} value else Fmt.pf ppf {|"%s"|} value
+
+  let to_raw_string t = t
+
+  let to_field_value t =
+    (* always weak comparison for If-None-Match header *)
+    let v = { weak= true; value= t } in
+    Fmt.str "%a" pp_header_etag_item v
+
+  let is_valid_char c =
+    let n = Char.code c in
+    (n >= 0x21 && n <= 0x7E && n <> 0x22) || (n >= 0x80 && n <= 0xFF)
+
+  let has_valid_charset s = String.for_all is_valid_char s
+
+  let of_crockford32 s =
+    match has_valid_charset s with
+    | false -> Error "invalid etag"
+    | true -> Ok s
+
+  let parse =
+    let open Angstrom in
+    let ws = skip_while (function ' ' -> true | _ -> false) in
+    let quoted_string =
+      char '"' *> take_till (fun c -> c = '"') <* char '"' >>= fun s ->
+      if String.for_all is_valid_char s then return s
+      else fail "found illegal char"
+    in
+    let item =
+      ws
+      *> lift2
+           (fun weak value -> { weak; value })
+           (option false (string "W/" *> return true))
+           quoted_string
+      <* ws
+    in
+    let comma = ws *> char ',' *> ws in
+    let list_of_items = sep_by1 comma item in
+    let parse_header_value =
+      char '*' *> return Any_etag
+      <|> (list_of_items >>| fun items -> Etag_list items)
+      <* end_of_input
+    in
+    fun s ->
+      match parse_string ~consume:Consume.All parse_header_value s with
+      | Error e -> Fmt.error "invalid etag: %s" e
+      | Ok v -> Ok v
+
+  let evaluate t header_value =
+    match header_value with
+    | Any_etag -> false
+    | Etag_list l ->
+        not @@ List.exists (fun { weak= _; value } -> String.equal t value) l
+end

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