From 67675fadceaa55b21e0b0749799a479eeb94e87b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 19 Nov 2024 22:17:58 +0000 Subject: [PATCH 1/3] Add roundtrip tests for XMLRPC, JSONRPC and regular Rpc.t MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- tests/lib/suite.ml | 1 + tests/lib/test_roundtrip.ml | 84 +++++++++++++++++++++++++++++++++++++ 2 files changed, 85 insertions(+) create mode 100644 tests/lib/test_roundtrip.ml diff --git a/tests/lib/suite.ml b/tests/lib/suite.ml index c0b1291..7aa0582 100644 --- a/tests/lib/suite.ml +++ b/tests/lib/suite.ml @@ -5,4 +5,5 @@ let () = ; "Json", Json.tests ; "Xml_xapi", Xml_xapi.tests ; "Encoding", Encoding.tests + ; "Rpc.t roundtrip", Test_roundtrip.tests ] diff --git a/tests/lib/test_roundtrip.ml b/tests/lib/test_roundtrip.ml new file mode 100644 index 0000000..f134509 --- /dev/null +++ b/tests/lib/test_roundtrip.ml @@ -0,0 +1,84 @@ +let pp_rpc = Fmt.of_to_string Rpc.to_string + +let make_test (type a) name kind input to_rpc to_wire pp_wire of_wire of_rpc = + let open Alcotest.V1 in + test_case name `Quick + @@ fun () -> + let module T = (val kind : TESTABLE with type t = a) in + Format.printf "%s: %a@." name T.pp input; + (* log line by line: any of these can raise an exception, + and we need to see how far we've got to debug *) + let rpc_in = input |> to_rpc in + Format.printf " -> %s@." (Rpc.to_string rpc_in); + let wire = rpc_in |> to_wire in + Format.printf " -> %a@." pp_wire wire; + let rpc_out = wire |> of_wire in + Format.printf " -> %s@." (Rpc.to_string rpc_out); + let actual = rpc_out |> of_rpc in + Format.printf " -> %a@." T.pp actual; + let msg = + Format.asprintf + "%s: %a -> %s -> %a -> %s -> %a" + name + T.pp + input + (Rpc.to_string rpc_in) + pp_wire + wire + (Rpc.to_string rpc_out) + T.pp + actual + in + check' kind ~msg ~expected:input ~actual + + +let rpc_of_base64_encode str = str |> Base64.encode_string |> Rpc.rpc_of_base64 + +let make_tests name to_wire pp_wire of_wire = + let make_test name' kind input to_rpc of_rpc = + make_test (name ^ "/" ^ name') kind input to_rpc to_wire pp_wire of_wire of_rpc + in + let open Alcotest.V1 in + [ make_test "Int" int Int.max_int Rpc.rpc_of_int Rpc.int_of_rpc + ; make_test "Int32" int32 Int32.max_int Rpc.rpc_of_int32 Rpc.int32_of_rpc + ; make_test "Bool" bool true Rpc.rpc_of_bool Rpc.bool_of_rpc + ; make_test "Float" (float 0.1) 2.3 Rpc.rpc_of_float Rpc.float_of_rpc + ; make_test "String" string "foo" Rpc.rpc_of_string Rpc.string_of_rpc + ; make_test + "enum" + (list string) + [ "a"; "x" ] + (fun l -> Rpc.Enum (l |> List.map Rpc.rpc_of_string)) + (function + | Rpc.Enum l -> List.map Rpc.string_of_rpc l + | _ -> failwith "bad value") + ; make_test + "dict" + (list (pair string int)) + [ "a", 1; "b", 2 ] + (fun l -> Rpc.Dict (l |> List.map (fun (k, v) -> k, Rpc.rpc_of_int v))) + (function + | Rpc.Dict l -> List.map (fun (k, v) -> k, Rpc.int_of_rpc v) l + | _ -> failwith "bad value") + ; make_test "unit" unit () Rpc.rpc_of_unit Rpc.unit_of_rpc +(* JSONRPC is broken here, will be reenabled in followup commits + ; make_test "DateTime" string "2024-01-01" Rpc.rpc_of_dateTime Rpc.dateTime_of_rpc + ; make_test "Int32.compat" int32 Int32.min_int (fun i -> Rpc.Int32 i) Rpc.int32_of_rpc + ; make_test "Base64" string "\x01\x00\x02" rpc_of_base64_encode Rpc.base64_of_rpc*) + ] + + +let tests : unit Alcotest.V1.test_case list = + [ make_tests + "XMLRPC" + (fun rpc -> Xmlrpc.to_string rpc) + Fmt.string + (fun str -> Xmlrpc.of_string str) + ; make_tests + "JSONRPC" + (fun rpc -> Jsonrpc.to_string rpc) + Fmt.string + (fun str -> Jsonrpc.of_string str) + ; make_tests "Rpc.t" Fun.id pp_rpc Fun.id + ] + |> List.concat From ade14a5cb76328f261166696fc4c76b38e523eb0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 19 Nov 2024 21:17:53 +0000 Subject: [PATCH 2/3] int32_of_rpc should not fail on Int32 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Rpc.Int32 is never created by this library, but XAPI does create it for backwards compatibility with its XMLRPC events protocol. Using either JSONRPC or XMLRPC to marshal/unmarshal works, but passing an Rpc.t directly fails. Signed-off-by: Edwin Török --- src/lib/rpc.ml | 1 + tests/lib/test_roundtrip.ml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/lib/rpc.ml b/src/lib/rpc.ml index 15de95c..f26ad36 100644 --- a/src/lib/rpc.ml +++ b/src/lib/rpc.ml @@ -194,6 +194,7 @@ let int64_of_rpc = function let int32_of_rpc = function | Int i -> Int64.to_int32 i + | Int32 i -> i | String s -> Int32.of_string s | x -> failwith (Printf.sprintf "Expected int32, got '%s'" (to_string x)) diff --git a/tests/lib/test_roundtrip.ml b/tests/lib/test_roundtrip.ml index f134509..b6bf1bb 100644 --- a/tests/lib/test_roundtrip.ml +++ b/tests/lib/test_roundtrip.ml @@ -61,9 +61,9 @@ let make_tests name to_wire pp_wire of_wire = | Rpc.Dict l -> List.map (fun (k, v) -> k, Rpc.int_of_rpc v) l | _ -> failwith "bad value") ; make_test "unit" unit () Rpc.rpc_of_unit Rpc.unit_of_rpc + ; make_test "Int32.compat" int32 Int32.min_int (fun i -> Rpc.Int32 i) Rpc.int32_of_rpc (* JSONRPC is broken here, will be reenabled in followup commits ; make_test "DateTime" string "2024-01-01" Rpc.rpc_of_dateTime Rpc.dateTime_of_rpc - ; make_test "Int32.compat" int32 Int32.min_int (fun i -> Rpc.Int32 i) Rpc.int32_of_rpc ; make_test "Base64" string "\x01\x00\x02" rpc_of_base64_encode Rpc.base64_of_rpc*) ] From 75f1af67a6cd77dea0058a198a1f38391cb7af94 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 19 Nov 2024 22:17:58 +0000 Subject: [PATCH 3/3] Fix unmarshaling datetime and base64 for JSONRPC MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit JSONRPC marshals these as string, but then trying to unmarshal would raise an exception. We need to accept String when unmarshaling DateTime and Base64 too. Some type safety is lost, because JSON doesn't have a way to distinguish between these (XMLRPC does). Update the unit test to check that this now works. Signed-off-by: Edwin Török --- src/lib/rpc.ml | 4 ++-- tests/lib/test_roundtrip.ml | 3 +-- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/lib/rpc.ml b/src/lib/rpc.ml index f26ad36..d610ee7 100644 --- a/src/lib/rpc.ml +++ b/src/lib/rpc.ml @@ -224,12 +224,12 @@ let string_of_rpc = function let dateTime_of_rpc = function - | DateTime s -> s + | DateTime s | String s -> s | x -> failwith (Printf.sprintf "Expected DateTime, got '%s'" (to_string x)) let base64_of_rpc = function - | Base64 s -> Base64.decode_exn s + | Base64 s | String s -> Base64.decode_exn s | x -> failwith (Printf.sprintf "Expected base64, got '%s'" (to_string x)) diff --git a/tests/lib/test_roundtrip.ml b/tests/lib/test_roundtrip.ml index b6bf1bb..00a1658 100644 --- a/tests/lib/test_roundtrip.ml +++ b/tests/lib/test_roundtrip.ml @@ -62,9 +62,8 @@ let make_tests name to_wire pp_wire of_wire = | _ -> failwith "bad value") ; make_test "unit" unit () Rpc.rpc_of_unit Rpc.unit_of_rpc ; make_test "Int32.compat" int32 Int32.min_int (fun i -> Rpc.Int32 i) Rpc.int32_of_rpc -(* JSONRPC is broken here, will be reenabled in followup commits ; make_test "DateTime" string "2024-01-01" Rpc.rpc_of_dateTime Rpc.dateTime_of_rpc - ; make_test "Base64" string "\x01\x00\x02" rpc_of_base64_encode Rpc.base64_of_rpc*) + ; make_test "Base64" string "\x01\x00\x02" rpc_of_base64_encode Rpc.base64_of_rpc ]