Allow the generated server code to optionally filter incoming messages.

diff --git a/gen/rpc/codegen.ml b/gen/rpc/codegen.ml
index cfb22ce547a299b295bc6aeaad82d81d6729b2bd..2c52ea9fe59e969440b6aa5f006d25ee665cc603 100644 (file)
--- a/gen/rpc/codegen.ml
+++ b/gen/rpc/codegen.ml
@@ -104,11 +104,37 @@ module Server = struct
                                let sg = sg @ [ "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
+                | 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 "@]@\n}@\n@\n";
                sig_name
 
+       let gen_messages_handled_list ff rpc_list notif_list =
+               if List.length rpc_list = 0 then
+                       fprintf ff "let rpcs_handled = []@,@,"
+               else begin
+                       fprintf ff "@[<v 8>let rpcs_handled = [";
+                       List.iter (fun r ->
+                                       fprintf ff "@,\"%s\";" (fst r).rpc_request.request_name
+                                 ) rpc_list;
+                       fprintf ff "@]@,]@,@,"
+               end;
+               if List.length notif_list = 0 then
+                       fprintf ff "let notifications_handled = []@,@,"
+               else begin
+                       fprintf ff "@[<v 8>let notifications_handled = [";
+                       List.iter (fun n ->
+                                       fprintf ff "@,\"%s\";" n.rpc_request.request_name
+                                 ) notif_list;
+                       fprintf ff "@]@,]@,@,"
+               end
+
        let gen_param ff venv otvn i p =
                let arg, venv = Var_env.new_ident_from_name venv p.param_name in
                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;
@@ -182,6 +208,10 @@ module Server = struct
                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;
+               (match server.server_message_filter with
+                | Some f -> fprintf ff "%s.%s %s.Jsonrpc.method_name;@," implvn f reqvn
+                | None -> ()
+               );
                fprintf ff "@[<v 8>let %s =@," pvn;
                fprintf ff "@[<v 8>(try@,";
                fprintf ff "match %s.Jsonrpc.method_name with@," reqvn;
@@ -277,6 +307,7 @@ let generate_server ff spec s =
        Server.start_server ff s;
        let rpc_list, notif_list = get_sorted_rpcs_by_server spec s in
        let sig_name = Server.gen_dispatch_struct ff s rpc_list notif_list in
+       Server.gen_messages_handled_list ff rpc_list notif_list;
        Server.gen_rpc_dispatch ff Var_env.new_env s sig_name rpc_list;
        Server.gen_notification_dispatch ff Var_env.new_env s sig_name notif_list;
        Server.gen_dispatch ff sig_name;

diff --git a/gen/rpc/syntax.ml b/gen/rpc/syntax.ml
index 2f9bf4dda386dd0d9fe7adc5763197ec285dc365..8834fa30c53bb47aabfebb43ed64d5f683cae6e1 100644 (file)
--- a/gen/rpc/syntax.ml
+++ b/gen/rpc/syntax.ml
@@ -22,6 +22,7 @@ type server =
 {
        server_name: string;
        server_doc: string;
+       server_message_filter: string option;
        server_error_handler: string;
 }
 

diff --git a/gen/rpc/syntax_json_conv.ml b/gen/rpc/syntax_json_conv.ml
index b50378b70bd85cf1f0aff2b5d7317eb6405c5984..e5306e3b28ee29625d7ee80ceebcaaded8bc92b2 100644 (file)
--- a/gen/rpc/syntax_json_conv.ml
+++ b/gen/rpc/syntax_json_conv.ml
@@ -27,14 +27,20 @@ let rec use_of_json j =
 
 let rec server_to_json o =
         (match o with
-        | { server_name = str; server_doc = str_1; server_error_handler = str_2 } ->
+        | { server_name = str; server_doc = str_1; server_message_filter = opt; server_error_handler = str_2 } ->
                 let j_str =
                         Json_conv.string_to_json str in
                 let j_str_1 =
                         Json_conv.string_to_json str_1 in
+                let j_opt =
+                        (match opt with
+                        | None -> Json.Null
+                        | Some str_3 ->
+                                Json_conv.string_to_json str_3
+                        ) in
                 let j_str_2 =
                         Json_conv.string_to_json str_2 in
-                Json.Object [| ("server_name", j_str); ("server_doc", j_str_1); ("server_error_handler", j_str_2) |]
+                Json.Object [| ("server_name", j_str); ("server_doc", j_str_1); ("server_message_filter", j_opt); ("server_error_handler", j_str_2) |]
         )
 
 let rec server_of_json j =
@@ -45,10 +51,17 @@ let rec server_of_json j =
         let server_doc_f = Json_conv.get_object_field j_ftable "server_doc" in
         let str_1 =
                 Json_conv.string_of_json server_doc_f in
+        let server_message_filter_f = Json_conv.get_optional_object_field j_ftable "server_message_filter" in
+        let opt =
+                (match server_message_filter_f with
+                | Json.Null -> None
+                | str_3 -> 
+                        Some (Json_conv.string_of_json str_3)
+                ) in
         let server_error_handler_f = Json_conv.get_object_field j_ftable "server_error_handler" in
         let str_2 =
                 Json_conv.string_of_json server_error_handler_f in
-        { server_name = str; server_doc = str_1; server_error_handler = str_2 }
+        { server_name = str; server_doc = str_1; server_message_filter = opt; server_error_handler = str_2 }
 
 let rec param_to_json o =
         (match o with

diff --git a/gen/rpc/tests/rpc_defns.json b/gen/rpc/tests/rpc_defns.json
index 6ba66687968f10c2df5079aed37c33006f4e8bf1..1bae7200ac369be44c5e2ce688e1c561a9b2e4c3 100644 (file)
--- a/gen/rpc/tests/rpc_defns.json
+++ b/gen/rpc/tests/rpc_defns.json
@@ -2,6 +2,7 @@
 
 { "server_name": "server",
   "server_doc": "",
+  "server_message_filter": "server_message_filter",
   "server_error_handler": "server_error_handler"
 }
 

diff --git a/gen/rpc/tests/test_rpc.ml b/gen/rpc/tests/test_rpc.ml
index e38b490343a05ff5807d218b093359c0167f7c2f..94132652090962d010e4cd16aa7b8d739b8611e6 100644 (file)
--- a/gen/rpc/tests/test_rpc.ml
+++ b/gen/rpc/tests/test_rpc.ml
@@ -39,11 +39,16 @@ module S = struct
        let error_handler e =
                2, Printexc.to_string e, Some (Json.String "details")
 
+       let message_filter s =
+               assert ((List.mem s Server.rpcs_handled)
+                       || (List.mem s Server.notifications_handled))
+
        let server_impl =
                { Server.request0_handler = req0_handler;
                  Server.request1_handler = req1_handler;
                  Server.request2_handler = req2_handler;
                  Server.not1_handler = not1_handler;
+                 Server.server_message_filter = message_filter;
                  Server.server_error_handler = error_handler
                }
 end