From: Prashanth Mundkur Date: Tue, 2 Jun 2009 22:27:11 +0000 (-0700) Subject: Allow the generated server code to optionally filter incoming messages. X-Git-Url: http://xenbits.xensource.com/gitweb?a=commitdiff_plain;h=c6b592e0c0f52989d99829e444f142c15d0ab81c;p=xenclient%2Ftoolstack.git Allow the generated server code to optionally filter incoming messages. --- diff --git a/gen/rpc/codegen.ml b/gen/rpc/codegen.ml index cfb22ce..2c52ea9 100644 --- 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 "@[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 "@[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 "@[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 "@[let %s =@," pvn; fprintf ff "@[(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 2f9bf4d..8834fa3 100644 --- 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 b50378b..e5306e3 100644 --- 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 6ba6668..1bae720 100644 --- 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 e38b490..9413265 100644 --- 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