let ff = formatter_of_out_channel oc in
oc, ff
-let generate_server spec fn =
+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_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;
+ Server.end_server ff;
+ 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;
+ Client.end_maker ff
+
+let generate_endpoint spec e fn =
let oc, ff = open_output fn in
generate_header ff;
generate_opens ff spec;
List.iter (fun 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_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;
- Server.end_server ff;
- fprintf ff "@\n@?"
- ) (get_servers spec);
- close_out oc
-
-let generate_client spec fn =
- let oc, ff = open_output fn in
- generate_header ff;
- generate_opens ff spec;
- List.iter (fun s ->
- let rpc_list = get_rpcs_by_server spec s in
- let rpcid_maker = Client.start_maker ff s in
- List.iter (Client.generate_rpc ff Var_env.new_env rpcid_maker s) rpc_list;
- Client.end_maker ff
- ) (get_servers spec);
- close_out oc
-
-let generate spec cfn sfn =
- generate_client spec cfn;
- generate_server spec sfn
+ generate_server ff spec s
+ ) (get_matching_servers spec e.endpoint_servers);
+ List.iter (fun c ->
+ generate_client ff spec c
+ ) (get_matching_servers spec e.endpoint_clients)
+
+let generate spec endpoints =
+ List.iter (fun (ep, outf) ->
+ generate_endpoint spec ep outf
+ ) endpoints
let stem = Filename.chop_extension base in
Filename.concat dir (stem ^ suffix)
+exception Invalid_endpoint_option of string
let parse_args () =
let input = ref "" in
- let client = ref "" in
- let server = ref "" in
+ let endpoints = ref [] in
+ let add_ep_output s =
+ try
+ let colon = String.index s ':' in
+ let len = String.length s in
+ let ep = String.sub s 0 colon in
+ let epfile = String.sub s (colon+1) (len - colon - 1) in
+ endpoints := (ep, epfile) :: !endpoints
+ with _ -> raise (Invalid_endpoint_option s) in
let options = [ ("-i", Arg.Set_string input, " input file");
- ("-c", Arg.Set_string client, " client interface");
- ("-s", Arg.Set_string server, " server interface")
+ ("-o", Arg.String add_ep_output, " endpoint:output_file");
] in
let usage = Printf.sprintf "Usage: %s [options]" Sys.argv.(0) in
let errmsg s = Printf.eprintf "%s\n" s; Arg.usage (Arg.align options) usage; exit 1 in
Arg.parse (Arg.align options) (fun s -> input := s) usage;
if !input = "" then errmsg "Unspecified input file!";
- if !client = "" then client := make_default_output_filename !input "_client.ml";
- if !server = "" then server := make_default_output_filename !input "_server.ml";
- !input, !client, !server
+ !input, !endpoints
let read_whole_file ic =
let buf = Buffer.create 2048 in
exception Unknown_rpc_decl of int * Json.t
exception Invalid_rpc_decl of int * (* type *) string * (* msg *) string
+exception Undefined_endpoint of string
let print_exception e =
let msg =
Printf.sprintf "Rpc declaration #%d is of unknown type." i
| Invalid_rpc_decl (i, n, m) ->
Printf.sprintf "Error parsing decl %d for %s: %s" i n m
+ | Undefined_endpoint e ->
+ Printf.sprintf "Endpoint \"%s\" not found in input file." e
| Sys_error s ->
Printf.sprintf "%s" s
| e ->
else if (Json_conv.is_object_field_present obj "rpc_type") then
try Rpc_decl.Rpc_rpc (rpc_of_json j)
with Json_conv.Json_conv_error err -> raise (Invalid_rpc_decl (i, "rpc", (Json_conv.string_of_error err)))
+ else if (Json_conv.is_object_field_present obj "endpoint_name") then
+ try Rpc_decl.Rpc_endpoint (endpoint_of_json j)
+ with Json_conv.Json_conv_error err -> raise (Invalid_rpc_decl (i, "endpoint", (Json_conv.string_of_error err)))
else
raise (Unknown_rpc_decl (i, j))
let _ =
- let input, client, server = parse_args () in
+ let input, endpoints = parse_args () in
try
let jdecls = parse_file input in
let decls = List.map process_jdecl jdecls in
let spec = Rpc_decl.spec_with_decls decls in
- Codegen.generate spec client server;
+ let gen = List.map (fun (n, outf) ->
+ let e = try Rpc_decl.get_endpoint_by_name spec n
+ with Not_found -> raise (Undefined_endpoint n)
+ in e, outf
+ ) endpoints in
+ Codegen.generate spec gen;
exit 0
with e ->
print_exception e;
| Rpc_use of use
| Rpc_server of server
| Rpc_rpc of rpc
+ | Rpc_endpoint of endpoint
-type elem = Server | RPC
+type elem = Server | RPC | Endpoint
-let elem_name = function Server -> "server" | RPC -> "rpc"
+let elem_name = function Server -> "server" | RPC -> "rpc" | Endpoint -> "endpoint"
type spec =
{
uses: string list;
servers: server list;
rpcs: rpc list;
+ endpoints: endpoint list;
}
let init_spec =
{
uses = [];
servers = [];
- rpcs = []
+ rpcs = [];
+ endpoints = [];
}
let get_rpcs_by_server spec server =
) ([], []) rpcs
in rlist, nlist
+let get_matching_servers spec names =
+ List.filter (fun s -> List.mem s.server_name names) spec.servers
+
+let get_endpoint_by_name spec name =
+ List.find (fun e -> e.endpoint_name = name) spec.endpoints
+
exception Multiple_decl of elem * string
exception Unknown_ref of elem * string
exception Unknown_RPC_type of string
match elem with
| Server -> ignore (List.find (fun s -> s.server_name = name) spec.servers); true
| RPC -> ignore (List.find (fun r -> (r.rpc_server ^ "." ^ r.rpc_request.request_name) = name) spec.rpcs); true
+ | Endpoint -> ignore (List.find (fun e -> e.endpoint_name = name) spec.endpoints); true
with Not_found -> false
let check_new spec elem name =
| s -> raise (Unknown_RPC_type s));
{ spec with rpcs = r :: spec.rpcs }
+let add_endpoint spec e =
+ check_new spec Endpoint e.endpoint_name;
+ List.iter (fun s -> check_existing spec Server s) e.endpoint_servers;
+ List.iter (fun c -> check_existing spec Server c) e.endpoint_clients;
+ { spec with endpoints = e :: spec.endpoints }
+
+let get_endpoints spec = List.rev spec.endpoints
+
let add_decl spec = function
| Rpc_use u -> add_use spec u
| Rpc_server s -> add_server spec s
| Rpc_rpc r -> add_rpc spec r
+ | Rpc_endpoint e -> add_endpoint spec e
let error_message e =
match e with
rpc_response: response option;
}
+type endpoint =
+{
+ endpoint_name: string;
+ endpoint_servers: string list;
+ endpoint_clients: string list;
+}
) in
{ rpc_type = str; rpc_server = str_1; rpc_doc = str_2; rpc_version = str_3; rpc_deprecated = opt; rpc_label_arguments = opt_1; rpc_request = request; rpc_response = opt_2 }
+let rec endpoint_to_json o =
+ (match o with
+ | { endpoint_name = str; endpoint_servers = lst; endpoint_clients = lst_1 } ->
+ let j_str =
+ Json_conv.string_to_json str in
+ let j_lst =
+ let lst_jlist = List.map
+ (fun str_1 ->
+ Json_conv.string_to_json str_1
+ ) lst in
+ Json.Array (Array.of_list lst_jlist) in
+ let j_lst_1 =
+ let lst_1_jlist = List.map
+ (fun str_1 ->
+ Json_conv.string_to_json str_1
+ ) lst_1 in
+ Json.Array (Array.of_list lst_1_jlist) in
+ Json.Object [| ("endpoint_name", j_str); ("endpoint_servers", j_lst); ("endpoint_clients", j_lst_1) |]
+ )
+
+let rec endpoint_of_json j =
+ let j_ftable = Json_conv.get_object_table j in
+ let endpoint_name_f = Json_conv.get_object_field j_ftable "endpoint_name" in
+ let str =
+ Json_conv.string_of_json endpoint_name_f in
+ let endpoint_servers_f = Json_conv.get_object_field j_ftable "endpoint_servers" in
+ let lst =
+ let endpoint_servers_f_oarray = Array.map
+ (fun str_1 ->
+ Json_conv.string_of_json str_1
+ ) (Json_conv.get_array endpoint_servers_f) in
+ Array.to_list endpoint_servers_f_oarray in
+ let endpoint_clients_f = Json_conv.get_object_field j_ftable "endpoint_clients" in
+ let lst_1 =
+ let endpoint_clients_f_oarray = Array.map
+ (fun str_1 ->
+ Json_conv.string_of_json str_1
+ ) (Json_conv.get_array endpoint_clients_f) in
+ Array.to_list endpoint_clients_f_oarray in
+ { endpoint_name = str; endpoint_servers = lst; endpoint_clients = lst_1 }
+
rpc_types_json_conv.ml: rpc_types.ml $(JSON_CONV)
$(JSON_GEN_CONV_DIR)/$(JSON_CONV_PROG) -i $< -o $@
-rpc_defns_client.ml rpc_defns_server.ml: rpc_defns.json $(GEN_RPC)
- $(JSON_GEN_RPC_DIR)/$(GEN_RPC_PROG) $<
+rpc_one.ml rpc_two.ml: rpc_defns.json $(GEN_RPC)
+ $(JSON_GEN_RPC_DIR)/$(GEN_RPC_PROG) -o 'one:rpc_one.ml' -o 'two:rpc_two.ml' $<
OCAMLFLAGS += -I $(JSON_LIB_DIR) -I $(JSON_RPC_LIB_DIR)
RPC_TEST_FILES[] =
rpc_types
rpc_types_json_conv
- rpc_defns_client
- rpc_defns_server
+ rpc_one
+ rpc_two
test_rpc
}
},
- "rpc_deprecated": "string",
+ "rpc_deprecated": "some notes",
"rpc_label_arguments": false
}
}
},
- "rpc_deprecated": "string",
+ "rpc_deprecated": "some notes",
"rpc_label_arguments": false
}
"rpc_label_arguments": true
}
+
+{ "endpoint_name": "one",
+ "endpoint_servers": [ "server" ],
+ "endpoint_clients": [ "server1" ]
+}
+
+{ "endpoint_name": "two",
+ "endpoint_servers": [ "server1" ],
+ "endpoint_clients": [ "server" ]
+}
open Rpc_types
open Rpc_types_json_conv
-open Rpc_defns_server
-open Rpc_defns_client
+open Rpc_one
+open Rpc_two
(* First, implement the Json-rpc id generator. *)
module I : Jsonrpc.Rpc_id_generator = struct
projects / xenclient / toolstack.git / commitdiff