Added a callback arg to generated server-side dispatchers.

diff --git a/gen/rpc/codegen.ml b/gen/rpc/codegen.ml
index 531e22e59767dfa944296c47020797ac5da49f76..2d8efc9934924871c95eb122830923df867e507d 100644 (file)
--- a/gen/rpc/codegen.ml
+++ b/gen/rpc/codegen.ml
@@ -86,13 +86,13 @@ module Server = struct
                        |  _ -> List.map (fun p -> p.param_type) params
                in
                let sig_name = (String.lowercase server.server_name) ^ "_impl" in
-               fprintf ff "type %s =@\n" sig_name;
+               fprintf ff "type 'a %s =@\n" sig_name;
                fprintf ff "@[<v 8>{@,";
                if List.length rpc_list > 0 then
                        fprintf ff "(* RPCs *)";
                List.iter (fun (rpc, resp) ->
                                let sg = get_arg_types rpc.rpc_request.request_params in
-                               let sg = sg @ [ resp.response_value.param_type ] in
+                               let sg = sg @ [ "'a"; resp.response_value.param_type ] in
                                fprintf ff "@,%s: %s;" rpc.rpc_request.request_handler (String.concat " -> " sg)
                          ) rpc_list;
                if List.length notif_list > 0 then
@@ -101,17 +101,17 @@ module Server = struct
                         else fprintf ff "(* Notifications *)");
                List.iter (fun n ->
                                let sg = get_arg_types n.rpc_request.request_params in
-                               let sg = sg @ [ "unit" ] in
+                               let sg = sg @ [ "'a"; "unit" ] in
                                fprintf ff "@,%s: %s;" n.rpc_request.request_handler (String.concat " -> " sg)
                          ) notif_list;
                (match server.server_message_filter with
                 | Some f ->
                        fprintf ff "@,@,(* Message filter *)";
-                       fprintf ff "@,%s: string -> unit;" f
+                       fprintf ff "@,%s: string -> 'a -> unit;" f
                 | None -> ()
                );
                fprintf ff "@,@,(* Exception error handler *)";
-               fprintf ff "@,%s: exn -> (int (* error code *) * string (* error msg *) * Json.t option (* optional data *)) " server.server_error_handler;
+               fprintf ff "@,%s: exn -> 'a -> Jsonrpc.rpc_error; " server.server_error_handler;
                fprintf ff "@]@\n}@\n@\n";
                sig_name
 
@@ -140,7 +140,7 @@ module Server = struct
                fprintf ff "let %s = %s (Json_conv.get_object_field %s \"%s\") in@," (name_of_var arg) (Type_conv.of_json p.param_type) otvn p.param_name;
                arg, venv
 
-       let gen_request ff venv reqv impl_module rpc resp =
+       let gen_request ff venv reqv impl_module cbvn rpc resp =
                let otv, venv = Var_env.new_ident_from_name venv "params" in
                let otvn, reqvn = name_of_var otv, name_of_var reqv in
                let methname = rpc.rpc_request.request_handler in
@@ -163,11 +163,11 @@ module Server = struct
                let respv, venv = Var_env.new_ident_from_name venv "resp" in
                let respjv, venv = Var_env.new_ident_from_name venv "resp_j" in
                let respvn, respjvn = name_of_var respv, name_of_var respjv in
-               fprintf ff "let %s = %s.%s %s in@," respvn impl_module methname args_str;
+               fprintf ff "let %s = %s.%s %s %s in@," respvn impl_module methname args_str cbvn;
                fprintf ff "let %s = %s %s in@," respjvn (Type_conv.to_json resp.response_value.param_type) respvn;
                fprintf ff "Jsonrpc.Result %s@]@," respjvn
 
-       let gen_notification ff venv reqv impl_module rpc =
+       let gen_notification ff venv reqv impl_module cbvn rpc =
                let otv, venv = Var_env.new_ident_from_name venv "params" in
                let otvn, reqvn = name_of_var otv, name_of_var reqv in
                let methname = rpc.rpc_request.request_handler in
@@ -187,16 +187,17 @@ module Server = struct
                                (String.concat " " (List.map (fun v -> name_of_var v) (List.rev paramsv))), venv
                        )
                in
-               fprintf ff "%s.%s %s@]@," impl_module methname args_str
+               fprintf ff "%s.%s %s %s@]@," impl_module methname args_str cbvn
 
        let gen_notification_dispatch ff venv server impl_module nlist =
                let dispv, venv = Var_env.new_ident_from_name venv "dispatch_notification" in
                let reqv, venv = Var_env.new_ident_from_name venv "req" in
+               let cbv, venv = Var_env.new_ident_from_name venv "callback_arg" in
                let implv, venv = Var_env.new_ident_from_name venv impl_module in
-               let reqvn, implvn = name_of_var reqv, name_of_var implv in
-               fprintf ff "@[<v 8>let %s (%s : %s) %s =@," (name_of_var dispv) implvn impl_module reqvn;
+               let reqvn, cbvn, implvn = name_of_var reqv, name_of_var cbv, name_of_var implv in
+               fprintf ff "@[<v 8>let %s %s %s %s =@," (name_of_var dispv) implvn reqvn cbvn;
                fprintf ff "match %s.Jsonrpc.method_name with@," reqvn;
-               List.iter (fun n -> gen_notification ff venv reqv implvn n) nlist;
+               List.iter (fun n -> gen_notification ff venv reqv implvn cbvn n) nlist;
                fprintf ff "| _ -> raise (Jsonrpc.Unknown_request %s.Jsonrpc.method_name)@]@,@\n" reqvn
 
        let gen_rpc_dispatch ff venv server impl_module rpcs =
@@ -205,32 +206,34 @@ module Server = struct
                let reqv, venv = Var_env.new_ident_from_name venv "req" in
                let implv, venv = Var_env.new_ident_from_name venv impl_module in
                let pv, venv = Var_env.new_ident_from_name venv "payload" in
-               let reqidjvn, reqvn, implvn, pvn = name_of_var reqidjv, name_of_var reqv, name_of_var implv, name_of_var pv in
-               fprintf ff "@[<v 8>let %s (%s : %s) %s %s =@," (name_of_var dispv) implvn impl_module reqidjvn reqvn;
+               let cbv, venv = Var_env.new_ident_from_name venv "callback_arg" in
+               let reqidjvn, reqvn, implvn = name_of_var reqidjv, name_of_var reqv, name_of_var implv in
+               let pvn, cbvn = name_of_var pv, name_of_var cbv in
+               fprintf ff "@[<v 8>let %s %s %s %s %s =@," (name_of_var dispv) implvn reqidjvn reqvn cbvn;
                (match server.server_message_filter with
-                | Some f -> fprintf ff "%s.%s %s.Jsonrpc.method_name;@," implvn f reqvn
+                | Some f -> fprintf ff "%s.%s %s.Jsonrpc.method_name %s;@," implvn f reqvn cbvn
                 | None -> ()
                );
                fprintf ff "@[<v 8>let %s =@," pvn;
                fprintf ff "@[<v 8>(try@,";
                fprintf ff "match %s.Jsonrpc.method_name with@," reqvn;
-               List.iter (fun (rpc, resp) -> gen_request ff venv reqv implvn rpc resp) rpcs;
+               List.iter (fun (rpc, resp) -> gen_request ff venv reqv implvn cbvn rpc resp) rpcs;
                fprintf ff "| _ -> raise (Jsonrpc.Unknown_request %s.Jsonrpc.method_name)@]@," reqvn;
                let ev, venv = Var_env.new_ident_from_name venv "e" in
                let errv, venv = Var_env.new_ident_from_name venv "err" in
                let evn, errvn = name_of_var ev, name_of_var errv in
                fprintf ff "@[<v 8> with %s ->@," evn;
-               fprintf ff "let %s = %s.%s %s in@," errvn implvn server.server_error_handler evn;
+               fprintf ff "let %s = %s.%s %s %s in@," errvn implvn server.server_error_handler evn cbvn;
                fprintf ff "Jsonrpc.Error %s)@]@]@," errvn;
                fprintf ff "in@,";
                fprintf ff "Jsonrpc.response_to_json { Jsonrpc.response_id = %s; Jsonrpc.response = %s }@]@,@\n" reqidjvn pvn
 
        let gen_dispatch ff impl_name =
-               fprintf ff "@[<v 8>let dispatch (%s : %s) req_j =@," impl_name impl_name;
+               fprintf ff "@[<v 8>let dispatch %s req_j callback_arg =@," impl_name;
                fprintf ff "let req = Jsonrpc.request_of_json req_j in@,";
                fprintf ff "match req.Jsonrpc.request_id with@,";
-               fprintf ff "| None -> ignore (dispatch_notification %s req); None@," impl_name;
-               fprintf ff "| Some id -> Some (dispatch_rpc %s id req)@]@,@\n" impl_name
+               fprintf ff "| None -> ignore (dispatch_notification %s req callback_arg); None@," impl_name;
+               fprintf ff "| Some id -> Some (dispatch_rpc %s id req callback_arg)@]@,@\n" impl_name
 end
 
 module Client = struct

diff --git a/gen/rpc/tests/test_rpc.ml b/gen/rpc/tests/test_rpc.ml
index a702685b4f5cbb13c1620e557c383c152125a59b..5cc836e2594517e1d7df96ab49803f99f0357e56 100644 (file)
--- a/gen/rpc/tests/test_rpc.ml
+++ b/gen/rpc/tests/test_rpc.ml
@@ -42,27 +42,27 @@ module C = Make_server_client (I)
 
 (* Finally, implement the server-side call dispatch structure. *)
 module S = struct
-       let req0_handler () = Some true
+       let req0_handler () () = Some true
 
-       let req1_handler arg1 =
+       let req1_handler arg1 () =
                if arg1 < 5 then None
                else if arg1 < 10 then Some false
                else Some true
 
-       let req2_handler arg1 arg2 arg3 =
+       let req2_handler arg1 arg2 arg3 () =
                ((string_of_int arg1)
                 ^ ".[" ^ (String.concat "," (List.map (fun (s, i) -> s ^ "-" ^ (string_of_int i)) arg2))
                 ^ "]." ^ (if arg3 then "true" else "false"))
 
-       let not1_handler arg1 arg2 arg3 =
+       let not1_handler arg1 arg2 arg3 () =
                assert ((arg1 = 5)
                        && (arg2 = ["5", 5; "10", 10])
                        && arg3)
 
-       let error_handler e =
+       let error_handler e () =
                2, Printexc.to_string e, Some (Json.String "details")
 
-       let message_filter s =
+       let message_filter s () =
                assert ((List.mem s Server.rpcs_handled)
                        || (List.mem s Server.notifications_handled))
 
@@ -95,7 +95,7 @@ let rpc_invoke req resp_fun =
                        | Json_parse.Json_parse_incomplete _ -> raise (Failure "server json parsing") in
 
        (* ii) dispatch the request *)
-       let resp_j = Server.dispatch S.server_impl jreq_s in
+       let resp_j = Server.dispatch S.server_impl jreq_s () in
 
        (* iii) check whether we have a response to send back *)
        let resp_j = match resp_j with
@@ -139,7 +139,7 @@ let notification_invoke testname req =
                        | Json_parse.Json_parse_incomplete _ -> raise (Failure "server json parsing") in
 
        (* ii) dispatch the request *)
-       let resp_j = Server.dispatch S.server_impl jreq_s in
+       let resp_j = Server.dispatch S.server_impl jreq_s () in
 
        (* iii) check whether we have a response to send back *)
        (match resp_j with
@@ -167,7 +167,7 @@ let test_invoke req ?(id_check=default_id_check) ?(error_check=default_error_che
 let test_server () =
        let req0_checker test_id () =
                let req, rpcid, resp_fn = C.jrpc_request0 () in
-               let exp_resp = S.req0_handler () 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
@@ -182,7 +182,7 @@ let test_server () =
 
        let req1_checker test_id arg1 =
                let req, rpcid, resp_fn = C.jrpc_request1 arg1 in
-               let exp_resp = S.req1_handler 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
@@ -199,7 +199,7 @@ let test_server () =
 
        let req2_checker test_id arg1 arg2 arg3 =
                let req, rpcid, resp_fn = C.jrpc_request2 arg1 arg2 arg3 in
-               let exp_resp = S.req2_handler 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