Merge pull request #221 from mseri/rrd_ppx

CP-26583: Port Rrdd interface to PPX-based RPCs

Author: mseri

lib_test/gpumon_interface_test.ml

@@ -1,11 +1,10 @@
-
-
+open Idl_test_common
 
 module GenPath = struct let test_data_path = "gpu_gen" end
 module OldPath = struct let test_data_path = "test_data/gpumon" end
 
-module C = Gpumon_interface.RPC_API(Idl_test_common.GenTestData(GenPath))
-module T = Gpumon_interface.RPC_API(Idl_test_common.TestOldRpcs(OldPath))
+module C = Gpumon_interface.RPC_API(GenTestData(GenPath)(TJsonrpc))
+module T = Gpumon_interface.RPC_API(TestOldRpcs(OldPath)(TJsonrpc))
 
 let tests =
   !C.implementation @ !T.implementation

lib_test/idl_test_common.ml

@@ -27,14 +27,39 @@ let read_str filename =
 
 open Idl
 
-module type PATHS = sig
+module type CONFIG = sig
   val test_data_path : string
   (** Path under which we look for or generate requests and responses. For example,
       if test_data_path = 'foo', this module will search for or generate requests
       matching 'foo/requests/<RPC name>.request.<n>' and responses matching
       'foo/responses/<RPC name>.response.<n>' *)
 end
 
+module type MARSHALLER = sig
+  val string_of_call : Rpc.call -> string
+  val call_of_string : string -> Rpc.call
+  val string_of_response : Rpc.response -> string
+  val response_of_string : string -> Rpc.response
+  val to_string : Rpc.t -> string
+  val of_string : string -> Rpc.t
+end
+
+(* Slightly annoyingly, both RPC modules have a slightly different signature. Fix it here *)
+module TJsonrpc : MARSHALLER = struct
+  include Jsonrpc
+  let string_of_call call = string_of_call call
+  let string_of_response response = string_of_response response
+end
+
+module TXmlrpc : MARSHALLER = struct
+  include Xmlrpc
+  let call_of_string s = call_of_string s
+  let response_of_string s = response_of_string s
+  let of_string s = of_string s
+end
+
+
+
 (** The following module implements test cases that write test
     RPC requests and responses in JSON that can be used to
     verify that subsequent versions of an API can still parse
@@ -45,8 +70,8 @@ end
     this module.
 
     The test data will be written to the path specified in the
-    PATH module passed in *)
-module GenTestData (P:PATHS) = struct
+    CONFIG module passed in *)
+module GenTestData (C:CONFIG) (M:MARSHALLER) = struct
   type implementation = unit Alcotest.test_case list ref
 
   let tests : unit Alcotest.test_case list ref = ref []
@@ -63,14 +88,36 @@ module GenTestData (P:PATHS) = struct
   let returning a err = Returning (a, err)
   let (@->) = fun t f -> Function (t, f)
 
+  open M
+
   let declare name _ ty =
     let rec inner : type b. (((string * Rpc.t) list * Rpc.t list) list) -> b fn -> unit = fun params ->
       function
       | Function (t, f) -> begin
         let vs = Rpc_genfake.genall 2 (match t.Param.name with Some n -> n | None -> t.Param.typedef.Rpc.Types.name) t.Param.typedef.Rpc.Types.ty in
         let marshalled = List.map (fun v -> Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v) vs in
         match t.Param.name with
-        | Some n -> inner (List.flatten (List.map (fun marshalled -> List.map (fun (named,unnamed) -> (((n,marshalled)::named),unnamed)) params) marshalled)) f
+        | Some n ->
+          inner
+            (List.flatten
+              (List.map
+                (fun marshalled ->
+                  match marshalled, t.Param.typedef.Rpc.Types.ty with
+                  | Rpc.Enum [], Rpc.Types.Option _ ->
+                    params
+                  | Rpc.Enum [x], Rpc.Types.Option _ ->
+                    List.map
+                      (fun (named,unnamed) ->
+                        (((n, x)::named),unnamed))
+                      params
+                  | _, _ ->
+                    List.map
+                      (fun (named,unnamed) ->
+                        (((n,marshalled)::named),unnamed))
+                      params
+                ) marshalled
+              )
+            ) f
         | None -> inner (List.flatten (List.map (fun marshalled -> List.map (fun (named,unnamed) -> (named,(marshalled::unnamed))) params) marshalled)) f
       end
       | Returning (t, e) ->
@@ -85,40 +132,44 @@ module GenTestData (P:PATHS) = struct
           let call = Rpc.call wire_name args in
           call) params in
         List.iteri (fun i call ->
-          let request_str = Jsonrpc.string_of_call call in
+          let request_str = string_of_call call in
           write_str
-            (Printf.sprintf "%s/requests/%s.request.%d" P.test_data_path wire_name i)
+            (Printf.sprintf "%s/requests/%s.request.%d" C.test_data_path wire_name i)
             request_str) calls;
         let vs = Rpc_genfake.genall 2 (match t.Param.name with Some n -> n | None -> t.Param.typedef.Rpc.Types.name) t.Param.typedef.Rpc.Types.ty in
         let marshalled_vs = List.map (fun v -> Rpc.success (Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v)) vs in
         let errs = Rpc_genfake.genall 2 "error" e.Error.def.Rpc.Types.ty in
         let marshalled_errs = List.map (fun err -> Rpc.failure (Rpcmarshal.marshal e.Error.def.Rpc.Types.ty err)) errs in
         List.iteri (fun i response ->
-          let response_str = Jsonrpc.string_of_response response in
+          let response_str = string_of_response response in
           write_str
-            (Printf.sprintf "%s/responses/%s.response.%d" P.test_data_path wire_name i)
+            (Printf.sprintf "%s/responses/%s.response.%d" C.test_data_path wire_name i)
             response_str) (marshalled_vs @ marshalled_errs)
     in
     let test_fn () =
       let mkdir_safe p = begin try Unix.mkdir p 0o755 with Unix.Unix_error (EEXIST, _, _) -> () end in
-      mkdir_safe P.test_data_path;
-      mkdir_safe (Printf.sprintf "%s/requests" P.test_data_path);
-      mkdir_safe (Printf.sprintf "%s/responses" P.test_data_path);
+      mkdir_safe C.test_data_path;
+      mkdir_safe (Printf.sprintf "%s/requests" C.test_data_path);
+      mkdir_safe (Printf.sprintf "%s/responses" C.test_data_path);
       inner [[],[]] ty in
     tests := (Printf.sprintf "Generate test data for '%s'" (Idl.get_wire_name !description name), `Quick, test_fn) :: !tests
 end
 
-let get_arg call has_named name =
+let get_arg call has_named name is_opt =
   match has_named, name, call.Rpc.params with
   | true, Some n, (Rpc.Dict named)::unnamed -> begin
-    match List.partition (fun (x,_) -> x = n) named with
-    | (_,arg)::dups,others -> Result.Ok (arg, {call with Rpc.params = (Rpc.Dict (dups @ others))::unnamed })
-    | _,_ -> Result.Error (`Msg (Printf.sprintf "Expecting named argument '%s'" n))
+      match List.partition (fun (x,_) -> x = n) named with
+      | (_,arg)::dups,others when is_opt ->
+        Result.Ok (Rpc.Enum [arg], {call with Rpc.params = (Rpc.Dict (dups @ others))::unnamed })
+      | [], _others when is_opt -> Result.Ok (Rpc.Enum [], call)
+      | (_,arg)::dups,others ->
+        Result.Ok (arg, {call with Rpc.params = (Rpc.Dict (dups @ others))::unnamed })
+      | _,_ -> Result.Error (`Msg (Printf.sprintf "Expecting named argument '%s'" n))
     end
   | true, None, (Rpc.Dict named)::unnamed -> begin
-    match unnamed with
-    | head::tail -> Result.Ok (head, {call with Rpc.params = (Rpc.Dict named)::tail})
-    | _ -> Result.Error (`Msg "Incorrect number of arguments")
+      match unnamed with
+      | head::tail -> Result.Ok (head, {call with Rpc.params = (Rpc.Dict named)::tail})
+      | _ -> Result.Error (`Msg "Incorrect number of arguments")
     end
   | true, _, _ -> begin
       Result.Error (`Msg "Marshalling error: Expecting dict as first argument when named parameters exist")
@@ -127,9 +178,9 @@ let get_arg call has_named name =
       Result.Ok (head, {call with Rpc.params = tail})
     end
   | false, None, [] ->
-      Result.Error (`Msg "Incorrect number of arguments")
+    Result.Error (`Msg "Incorrect number of arguments")
   | false, Some _, _ ->
-      failwith "Can't happen by construction"
+    failwith "Can't happen by construction"
 
 exception NoDescription
 exception MarshalError of string
@@ -138,7 +189,7 @@ exception MarshalError of string
 (** The following module will generate alcotest test cases to verify
     that a set of requests and responses can be successfully parsed.
 
-    The PATHS module specifies the location for the test data as
+    The CONFIG module specifies the location for the test data as
     `test_data_path`. Requests and responses will be looked up in
     this location in the subdirectories `requests` and `responses`.
     The actual data must be in files following the naming convention
@@ -148,7 +199,7 @@ exception MarshalError of string
     ensure it accurately represents how the server would parse the
     json.
     *)
-module TestOldRpcs (P : PATHS) = struct
+module TestOldRpcs (C : CONFIG) (M : MARSHALLER) = struct
   open Rpc
   type implementation = unit Alcotest.test_case list ref
 
@@ -167,6 +218,8 @@ module TestOldRpcs (P : PATHS) = struct
   let returning a b = Returning (a,b)
   let (@->) = fun t f -> Function (t, f)
 
+  open M
+
   let rec has_named_args : type a. a fn -> bool =
     function
     | Function (t, f) -> begin
@@ -191,22 +244,31 @@ module TestOldRpcs (P : PATHS) = struct
     let rec read_all path extension i =
       try
         let call =
-          read_str (Printf.sprintf "%s/%s/%s.%s.%d" P.test_data_path path wire_name extension i) in
+          read_str (Printf.sprintf "%s/%s/%s.%s.%d" C.test_data_path path wire_name extension i) in
         call :: read_all path extension (i+1)
       with _ -> []
     in
 
-    let calls = read_all "requests" "request" 0 |> List.map Jsonrpc.call_of_string in
-    let responses = read_all "responses" "response" 0 |> List.map Jsonrpc.response_of_string in
+    let calls = read_all "requests" "request" 0 |> List.map call_of_string in
+    let responses = read_all "responses" "response" 0 |> List.map response_of_string in
 
     let verify : type a. a Rpc.Types.typ -> Rpc.t -> a = fun typ rpc ->
+      let rec sort_dicts ty =
+        let open Rpc in
+        match ty with
+        | Dict kvs' ->
+          let kvs = List.map (fun (k,v) -> (k, sort_dicts v)) kvs' in
+          Dict (List.sort (fun (k1,_) (k2,_) -> String.compare k1 k2) kvs)
+        | Enum ts -> Enum (List.map sort_dicts ts)
+        | _ -> ty
+      in
       match Rpcmarshal.unmarshal typ rpc with
       | Ok x ->
         let check = Rpcmarshal.marshal typ x in
-        if check <> rpc then begin
+        if (to_string (sort_dicts check)) <> (to_string (sort_dicts rpc)) then begin
           let err = Printf.sprintf "Round-trip failed. Before: '%s' After: '%s'"
-            (Jsonrpc.to_string rpc)
-            (Jsonrpc.to_string check) in
+            (to_string rpc)
+            (to_string check) in
           raise (MarshalError err)
         end;
         x
@@ -220,7 +282,8 @@ module TestOldRpcs (P : PATHS) = struct
         match f with
         | Function (t, f) -> begin
             let (arg_rpc, call') =
-              match get_arg call has_named t.Param.name  with
+              let is_opt = match t.Param.typedef.Rpc.Types.ty with Rpc.Types.Option _ -> true | _ -> false in
+              match get_arg call has_named t.Param.name is_opt with
               | Result.Ok (x,y) -> (x,y)
               | Result.Error (`Msg m) -> raise (MarshalError m)
             in

lib_test/memory_interface_test.ml

@@ -1,11 +1,11 @@
 
-
+open Idl_test_common
 
 module GenPath = struct let test_data_path = "mem_gen" end
 module OldPath = struct let test_data_path = "test_data/memory" end
 
-module C = Memory_interface.API(Idl_test_common.GenTestData(GenPath))
-module T = Memory_interface.API(Idl_test_common.TestOldRpcs(OldPath))
+module C = Memory_interface.API(GenTestData(GenPath)(TJsonrpc))
+module T = Memory_interface.API(TestOldRpcs(OldPath)(TJsonrpc))
 
 let tests =
   !C.implementation @ !T.implementation

lib_test/network_interface_test.ml

@@ -1,11 +1,12 @@
 
 
+open Idl_test_common
 
 module GenPath = struct let test_data_path = "net_gen" end
 module OldPath = struct let test_data_path = "test_data/network" end
 
-module C = Network_interface.Interface_API(Idl_test_common.GenTestData(GenPath))
-module T = Network_interface.Interface_API(Idl_test_common.TestOldRpcs(OldPath))
+module C = Network_interface.Interface_API(GenTestData(GenPath)(TJsonrpc))
+module T = Network_interface.Interface_API(TestOldRpcs(OldPath)(TJsonrpc))
 
 let tests =
   !C.implementation @ !T.implementation