Added response_handling codegen, which needed a slight change in request api. Extend...

diff --git a/gen/rpc/codegen.ml b/gen/rpc/codegen.ml
index 2c52ea9fe59e969440b6aa5f006d25ee665cc603..e0c40e88c6b45fc6066aafb6baa1c56d09762ab5 100644 (file)
--- a/gen/rpc/codegen.ml
+++ b/gen/rpc/codegen.ml
@@ -245,22 +245,46 @@ module Client = struct
                done;
                nm
 
+       let gen_handler_type ff resp =
+               let resp_type = resp.response_value.param_type in
+               fprintf ff "@,val %s : %s -> context -> unit" resp.response_handler resp_type
+
+       let client_modname s = Printf.sprintf "%s_client" (String.capitalize s.server_name)
+
+       let gen_resp_name rpc =
+               Printf.sprintf "jresp_%s" (gen_method_name rpc.rpc_request.request_name)
+
+       let generate_client_sig ff s rpcs =
+               fprintf ff "module type %s =@\n" (client_modname s);
+               fprintf ff "@[<v 8>sig";
+               fprintf ff "@,type rpc_id";
+               fprintf ff "@,type context";
+               fprintf ff "@,val get_new_rpc_id : unit -> rpc_id * Json.t";
+               List.iter (fun (rpc, resp) -> gen_handler_type ff resp) rpcs;
+               fprintf ff "@]@\nend@\n@\n@?"
+
        let start_maker ff s =
-               let rpcid_maker = "Rpc_id_maker" in
-               fprintf ff "module Make_%s_client (%s : Jsonrpc.Rpc_id_generator) =@\n" (String.lowercase s.server_name) rpcid_maker ;
+               let modname = client_modname s in
+               fprintf ff "module Make_%s_client (%s : %s) =@\n" (String.lowercase s.server_name) modname modname;
                fprintf ff "@[<v 8>struct";
-               rpcid_maker
+               modname
 
        let end_maker ff =
                fprintf ff "@]@\nend@\n@\n@?"
 
-       let generate_rpc ff venv rpcid_maker s rpc =
+       let generate_resp_handler ff modname c (rpc, resp) =
+               fprintf ff "@,@[<v 8>let %s resp =@," (gen_resp_name rpc);
+               fprintf ff "%s.%s (%s resp)@]" modname resp.response_handler
+                       (Type_conv.of_json resp.response_value.param_type)
+
+       let generate_rpc ff venv modname s rpc =
                let params = rpc.rpc_request.request_params in
                let args = List.map (fun p -> p.param_name) params in
                let avlist, venv = Var_env.new_idents_from_names venv ~prefix:"o_" args in
                let vvlist, venv = Var_env.new_idents_from_names venv ~prefix:"j_" args in
                let rpcv, venv = Var_env.new_ident_from_name venv "rpc_id" in
-               let rpcvn = name_of_var rpcv in
+               let jrpcv, venv = Var_env.new_ident_from_name venv "jrpc_id" in
+               let rpcvn, jrpcvn = name_of_var rpcv, name_of_var jrpcv in
                let meth_name = gen_method_name rpc.rpc_request.request_name in
                let args_str =
                        (match args with
@@ -277,15 +301,21 @@ module Client = struct
                                                                 Printf.sprintf "\"%s\", %s" a (name_of_var v)
                                                              ) args vvlist
                                                   )
-                       )
-               in
+                       ) in
                (match rpc.rpc_response with
-               | None ->   fprintf ff "let %s = None in@," rpcvn
-               | Some _ -> fprintf ff "let %s = Some (%s.get_rpc_request_id ()) in@," rpcvn rpcid_maker);
-               fprintf ff "@[<v 2>{ Jsonrpc.request_id = %s;@," rpcvn;
+               | None ->
+                       fprintf ff "let %s = None in@," jrpcvn
+               | Some resp ->
+                       fprintf ff "let %s, %s = %s.get_new_rpc_id () in@," rpcvn jrpcvn modname;
+                       fprintf ff "let %s = Some %s in@," jrpcvn jrpcvn
+               );
+               fprintf ff "@[<v 2>{ Jsonrpc.request_id = %s;@," jrpcvn;
                fprintf ff "Jsonrpc.method_name = \"%s\";@," rpc.rpc_request.request_name;
                fprintf ff "Jsonrpc.params = Json.Object (Array.of_list [ %s ])" args_str;
-               fprintf ff "@]@,}@]"
+               (match rpc.rpc_response with
+                | None -> fprintf ff "@]@,}@]"
+                | Some _ -> fprintf ff "@]@,}, %s, %s@]" rpcvn (gen_resp_name rpc)
+               )
 end
 
 let generate_header ff =
@@ -315,9 +345,17 @@ let generate_server ff spec s =
        fprintf ff "@\n@?"
 
 let generate_client ff spec c =
-       let rpc_list = get_rpcs_by_server spec c in
-       let rpcid_maker = Client.start_maker ff c in
-       List.iter (Client.generate_rpc ff Var_env.new_env rpcid_maker c) rpc_list;
+       let rpc_list, _ = get_sorted_rpcs_by_server spec c in
+       let msg_list = get_rpcs_by_server spec c in
+       Client.generate_client_sig ff c rpc_list;
+       let modname = Client.start_maker ff c in
+       if List.length rpc_list > 0 then
+               fprintf ff "@,(* Response handling *)@,";
+       List.iter (Client.generate_resp_handler ff modname c) rpc_list;
+       fprintf ff "@,";
+       if List.length msg_list > 0 then
+               fprintf ff "@,(* Requests and notifications *)@,";
+       List.iter (Client.generate_rpc ff Var_env.new_env modname c) msg_list;
        Client.end_maker ff
 
 let generate_endpoint spec e fn =

diff --git a/gen/rpc/tests/test_rpc.ml b/gen/rpc/tests/test_rpc.ml
index 94132652090962d010e4cd16aa7b8d739b8611e6..a702685b4f5cbb13c1620e557c383c152125a59b 100644 (file)
--- a/gen/rpc/tests/test_rpc.ml
+++ b/gen/rpc/tests/test_rpc.ml
@@ -3,14 +3,37 @@ open Rpc_types_json_conv
 open Rpc_one
 open Rpc_two
 
-(* First, implement the Json-rpc id generator. *)
-module I : Jsonrpc.Rpc_id_generator = struct
-       let cur_id = ref 0L
+exception Dumb_test_error
+
+(* First, implement the response handling interface. *)
+module I = struct
+       type rpc_id = Int64.t
 
-       let get_rpc_request_id () =
+       let cur_id = ref 0L
+       let get_new_rpc_id () =
                let id = !cur_id in
                cur_id := Int64.add !cur_id 1L;
-               Json.Int id
+               id, Json.Int id
+
+       type context =
+               | Req0 of resp1_type
+               | Req1 of resp1_type
+               | Req2 of resp2_type
+
+       let response0_handler resp1 context =
+               match context with
+               | Req0 r -> assert (r = resp1); Printf.printf "response0_handler: response good\n\n"
+               | _ -> raise Dumb_test_error
+
+       let response1_handler resp2 context =
+               match context with
+               | Req1 r -> assert (r = resp2);  Printf.printf "response1_handler: response good\n\n"
+               | _ -> raise Dumb_test_error
+
+       let client_function resp2 context =
+               match context with
+               | Req2 r -> assert (r = resp2);  Printf.printf "client_function: response good\n\n"
+               | _ -> raise Dumb_test_error
 end
 
 (* Now, create the client-side wrappers. *)
@@ -143,28 +166,30 @@ let test_invoke req ?(id_check=default_id_check) ?(error_check=default_error_che
 
 let test_server () =
        let req0_checker test_id () =
-               let req = C.jrpc_request0 () in
+               let req, rpcid, resp_fn = C.jrpc_request0 () in
                let exp_resp = S.req0_handler () in
                let resp_to_str r = match r with |None -> "None" | Some b -> if b then "Some true" else "Some false" in
                let resp_checker r =
                        let got_resp = resp1_type_of_json r in
                        if got_resp <> exp_resp
                        then raise (Failure (Printf.sprintf "req1, test %s: got \"%s\", expected \"%s\"!"
-                                              test_id (resp_to_str got_resp) (resp_to_str exp_resp)))
+                                              test_id (resp_to_str got_resp) (resp_to_str exp_resp)));
+                       resp_fn r (I.Req0 exp_resp)
                in
                test_invoke req resp_checker
        in
        req0_checker "1" ();
 
        let req1_checker test_id arg1 =
-               let req = C.jrpc_request1 arg1 in
+               let req, rpcid, resp_fn = C.jrpc_request1 arg1 in
                let exp_resp = S.req1_handler arg1 in
                let resp_to_str r = match r with |None -> "None" | Some b -> if b then "Some true" else "Some false" in
                let resp_checker r =
                        let got_resp = resp1_type_of_json r in
                        if got_resp <> exp_resp
                        then raise (Failure (Printf.sprintf "req1, test %s: got \"%s\", expected \"%s\"!"
-                                              test_id (resp_to_str got_resp) (resp_to_str exp_resp)))
+                                              test_id (resp_to_str got_resp) (resp_to_str exp_resp)));
+                       resp_fn r (I.Req1 exp_resp)
                in
                test_invoke req resp_checker
        in
@@ -173,12 +198,13 @@ let test_server () =
        req1_checker "3" 13;
 
        let req2_checker test_id arg1 arg2 arg3 =
-               let req = C.jrpc_request2 arg1 arg2 arg3 in
+               let req, rpcid, resp_fn = C.jrpc_request2 arg1 arg2 arg3 in
                let exp_resp = S.req2_handler arg1 arg2 arg3 in
                let resp_checker r =
                        let got_resp = resp2_type_of_json r in
                        if got_resp <> exp_resp
-                       then raise (Failure (Printf.sprintf "req2, test %s: got \"%s\", expected \"%s\"!" test_id got_resp exp_resp))
+                       then raise (Failure (Printf.sprintf "req2, test %s: got \"%s\", expected \"%s\"!" test_id got_resp exp_resp));
+                       resp_fn r (I.Req2 exp_resp)
                in
                test_invoke req resp_checker
        in