From: Prashanth Mundkur Date: Thu, 4 Jun 2009 07:50:07 +0000 (-0700) Subject: Added a callback arg to generated server-side dispatchers. X-Git-Url: http://xenbits.xensource.com/gitweb?a=commitdiff_plain;h=23f356e8226e9c568bc70835a3ec70bd134ed014;p=xenclient%2Ftoolstack.git Added a callback arg to generated server-side dispatchers. --- diff --git a/gen/rpc/codegen.ml b/gen/rpc/codegen.ml index 531e22e..2d8efc9 100644 --- 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 "@[{@,"; 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 "@[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 "@[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 "@[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 "@[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 "@[let %s =@," pvn; fprintf ff "@[(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 "@[ 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 "@[let dispatch (%s : %s) req_j =@," impl_name impl_name; + fprintf ff "@[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 a702685..5cc836e 100644 --- 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