From dd668028ce9a40eaa29fa1362634781fd7b2674c Mon Sep 17 00:00:00 2001 From: swrup Date: Fri, 27 Feb 2026 17:49:54 +0100 Subject: [PATCH] --- src/api.ml | 16 +++++------ src/http_info.ml | 9 +++++- src/libtool_version.ml | 48 ++++++++++++++++++++++++++++++++ src/syntax.ml | 2 +- test/dune | 5 ++++ test/validate_response.ml | 58 +++++++++++++++++++++++++++++++++++++++ 6 files changed, 127 insertions(+), 11 deletions(-) create mode 100644 src/libtool_version.ml create mode 100644 test/validate_response.ml diff --git a/src/api.ml b/src/api.ml index 63bbba72..592083fa 100644 --- a/src/api.ml +++ b/src/api.ml @@ -8,8 +8,6 @@ - payto_uri - uri *) -let protocol_version = "31:0:0" - open Time open Crypto open Signatures @@ -206,7 +204,7 @@ end module ExchangeVersionResponse = struct type t = { - version: string; + version: Libtool_version.t; (* todo jsont const string `name: "taler-exchange"` *) name: string; @@ -241,7 +239,7 @@ module ExchangeVersionResponse = struct let currency_specification v = v.currency_specification in let aml_spa_dialect v = v.aml_spa_dialect in map ~kind:"ExchangeVersionResponse" make - |> mem "version" Jsont.string ~enc:version + |> mem "version" Libtool_version.jsont ~enc:version |> mem "name" Jsont.string ~enc:name |> mem "implementation" (Jsont.option Jsont.string) ~enc:implementation |> mem "currency" Jsont.string ~enc:currency @@ -273,7 +271,7 @@ let currency_specification = let config = ExchangeVersionResponse. { - version= protocol_version; + version= Libtool_version.mte_protocol_version; name= "taler-exchange"; currency= Config.currency; currency_specification; @@ -1230,7 +1228,7 @@ end module ExtensionManifest = struct type t = { critical: bool; - version: string; + version: Libtool_version.t; config: Jsont.json option; } @@ -1241,7 +1239,7 @@ module ExtensionManifest = struct let config v = v.config in map ~kind:"ExtensionManifest" make |> mem "critical" Jsont.bool ~enc:critical - |> mem "version" Jsont.string ~enc:version + |> mem "version" Libtool_version.jsont ~enc:version |> opt_mem "config" (Jsont.any ()) ~enc:config |> finish end @@ -1250,7 +1248,7 @@ module ExchangeKeysResponse = struct module String_map = Map.Make (String) type t = { - version: string; + version: Libtool_version.t; base_url: string; currency: string; shopping_url: string option; @@ -1366,7 +1364,7 @@ module ExchangeKeysResponse = struct let extensions v = v.extensions in let extensions_sig v = v.extensions_sig in map ~kind:"ExchangeKeysResponse" make - |> mem "version" Jsont.string ~enc:version + |> mem "version" Libtool_version.jsont ~enc:version |> mem "base_url" Jsont.string ~enc:base_url |> mem "currency" Jsont.string ~enc:currency |> opt_mem "shopping_url" Jsont.string ~enc:shopping_url diff --git a/src/http_info.ml b/src/http_info.ml index 68dd0519..4a20888d 100644 --- a/src/http_info.ml +++ b/src/http_info.ml @@ -20,8 +20,15 @@ let config req _server _env = let res = Api.encode Api.ExchangeVersionResponse.jsont config in Respond.result res req +(* not implemented: + - kyc + - wads + - account limits + - zero limited operations + - recoup + - extensions *) let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date = - let version = Api.protocol_version in + let version = Libtool_version.mte_protocol_version in let base_url = Config.base_url in let currency = Config.currency in let shopping_url = Config.shopping_url in diff --git a/src/libtool_version.ml b/src/libtool_version.ml new file mode 100644 index 00000000..74c94dcd --- /dev/null +++ b/src/libtool_version.ml @@ -0,0 +1,48 @@ +(* libtool version format: current[:revision[:age]] + https://www.gnu.org/software/libtool/manual/html_node/Libtool-versioning.html *) +open Syntax + +type t = { + (* The most recent interface number that this library implements *) + current: int; + (* The implementation number of the current interface *) + revision: int option; + (* The difference between the newest and oldest interfaces that this library implements *) + age: int option; +} + +let is_compatible ~implementation v = + v.current <= implementation.current + && implementation.current - Option.value ~default:0 implementation.age + <= v.current + +let of_string s = + let error = Fmt.error "string does not match a libtool version format" in + let to_int s = + match int_of_string_opt s with + | None -> error + | Some i -> if i < 0 then error else Ok i + in + let* l = String.split_on_char ':' s |> Syntax.list_map to_int in + match l with + | [] -> Fmt.failwith "not possible" + | [ current ] -> Ok { current; revision= None; age= None } + | [ current; revision ] -> Ok { current; revision= Some revision; age= None } + | [ current; revision; age ] -> + Ok { current; revision= Some revision; age= Some age } + | _ -> error + +let pp ppf v = + match v with + | { current; revision= None; age= None } -> Fmt.pf ppf "%d" current + | { current; revision= Some revision; age= None } -> + Fmt.pf ppf "%d:%d" current revision + | { current; revision= Some revision; age= Some age } -> + Fmt.pf ppf "%d:%d:%d" current revision age + | _ -> Fmt.failwith "corrupt version data: has age with no revision" + +let jsont = + Jsont.of_of_string ~kind:"libtool version" of_string ~enc:(Fmt.str "%a" pp) + +let mte_protocol_version = + "31:0:0" |> of_string |> function Error e -> Fmt.failwith "%s" e | Ok v -> v diff --git a/src/syntax.ml b/src/syntax.ml index f0585100..9282b2dd 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -56,7 +56,7 @@ let list_fold_left f acc l = f acc v) (Ok acc) l -let opt_list l = +let list_option l = match (List.for_all Option.is_none l, List.for_all Option.is_some l) with | _, true -> let l = List.map Option.get l in diff --git a/test/dune b/test/dune index 7e8b7438..a906ce1d 100644 --- a/test/dune +++ b/test/dune @@ -7,3 +7,8 @@ (name test_crypto) (modules test_crypto) (libraries mte fmt)) + +(executable + (name validate_response) + (modules validate_response) + (libraries mte fmt bos)) diff --git a/test/validate_response.ml b/test/validate_response.ml new file mode 100644 index 00000000..709f4464 --- /dev/null +++ b/test/validate_response.ml @@ -0,0 +1,58 @@ +open Syntax +(*open Crypto*) + +let keys content = + let open Api.ExchangeKeysResponse in + let* v = Api.decode jsont content in + (* validate version compatibility *) + let* () = + if + Libtool_version.is_compatible + ~implementation:Libtool_version.mte_protocol_version v.version + then Ok () + else Fmt.error "version incompatible" + in + + (* TODO *) + (* validate currency specification *) + (* validate all amounts *) + (* validate all timestamp/duration *) + (* validate master_public_key *) + (* validate accounts *) + (* validate wire-fees *) + (* validate signkeys *) + (* validate exchange_pub *) + (* validate denominations *) + (* validate exchange_sig *) + (* validate global-fees *) + (* validate list_issue_date *) + (* validate auditors *) + Ok () + +(* --- *) +open Cmdliner +open Cmdliner.Term.Syntax + +let keys_cmd = + let input = + let doc = "input file" in + Arg.(required & opt (some filepath) None & info [ "i"; "input" ] ~doc) + in + let doc = "validate a /keys JSON response" in + Cmd.make (Cmd.info "keys" ~doc) + @@ + let+ input = input in + let* content = + Result.bind (Fpath.of_string input) Bos.OS.File.read |> unwrap_err_msg + in + keys content + +let cli = + let info = + let doc = "Testing tool to validate exchange responses" in + Cmd.info "validate" ~doc + in + Cmd.group info [ keys_cmd ] + +let main () = Cmd.eval_result cli +let () = if !Sys.interactive then () else exit (main ())