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

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

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

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

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

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 ())