Permalink
Browse files

Update the IDL generator to handle exceptions.

Define your exceptions at the top level in your idl file, then raise
them in the server and they'll be reraised in the client.

Signed-off-by: Jon Ludlam <jonathan.ludlam@eu.citrix.com>
  • Loading branch information...
1 parent 47eb42f commit eb9be87ebeb26c8bc26513173a22b4ba1cdd238d David Scott committed Oct 23, 2012
Showing with 77 additions and 21 deletions.
  1. +77 −21 lib/p4_idl.ml
View
@@ -83,6 +83,19 @@ struct
((Rpc rpc)::cur,namespace)
| _ -> (cur,namespace)
+ let find_exns exns si =
+ match si with
+ | <:str_item< exception $ctyp$ >> ->
+ begin
+ match ctyp with
+ | <:ctyp< $uid:uid$ of $ty$ >> ->
+ (uid,Some ty)::exns
+ | <:ctyp< $uid:uid$ >> ->
+ (uid,None)::exns
+ end
+ | _ ->
+ exns
+
(* Create the Args module - this contains the of_rpc and to_rpc functions
used to convert the arguments of the function call to Rpc.t type. It
also contains converters for the return type, and a function to
@@ -141,8 +154,8 @@ struct
if response.Rpc.success
then Args.$arg_path$.response_of_rpc response.Rpc.contents
else
- let (msg,params) = failure_of_rpc response.Rpc.contents in
- raise (RpcFailure (msg, params)) >>
+ let e = exn_of_exnty (Exception.exnty_of_rpc response.Rpc.contents) in
+ raise e >>
in
let gen_client_fun rpc =
@@ -254,10 +267,7 @@ struct
($str:rpc.name$,$MyRpc.patt_list_of_list rpc.loc pattern_list$) ->
$outer$
| ($str:rpc.name$,_) ->
- raise (RpcFailure ("MESSAGE_PARAMETER_COUNT_MISMATCH",
- [("func",$str:rpc.name$);
- ("expected",$str:(string_of_int (List.length pattern_list))$);
- ("received",string_of_int (List.length call.Rpc.params))]))
+ raise (Message_param_count_mismatch ($str:rpc.name$,$`int:List.length pattern_list$,List.length call.Rpc.params))
>>
in
@@ -269,17 +279,14 @@ struct
try
let contents = match (call.Rpc.name, call.Rpc.params) with
[ $Ast.mcOr_of_list mcs$
- | (x,_) -> raise (RpcFailure ("Unknown RPC",[(x,"")]))]
+ | (x,_) -> raise (Unknown_RPC x)]
in { Rpc.success = True;
Rpc.contents = contents; }
with
- [ RpcFailure (x,y) ->
- { Rpc.success = False;
- Rpc.contents = rpc_of_failure (x,y); }
- | e ->
- { Rpc.success = False;
- Rpc.contents = rpc_of_failure ("INTERNAL_ERROR",[]) } ];
+ [ e ->
+ { Rpc.success = False;
+ Rpc.contents = Exception.rpc_of_exnty (exnty_of_exn e); } ];
end >>
@@ -291,6 +298,8 @@ struct
<:str_item< module $foo$ = struct $list:List.map filter_types (Ast.list_of_str_item sis [])$ end>>
| <:str_item@_loc< external $fname$ : $ctyp$ = $override$ >> ->
<:str_item< >>
+ | <:str_item@_loc< exception $_$ >> ->
+ <:str_item< >>
| _ -> si
and add_rpcs si lid body =
@@ -304,21 +313,64 @@ struct
AstFilters.register_str_item_filter begin fun si ->
let _loc = Ast.loc_of_str_item si in
let (rev_rpcs,_) = List.fold_left find_rpcs ([],[]) (Ast.list_of_str_item si []) in
+ let rev_exns = List.fold_left find_exns [] (Ast.list_of_str_item si []) in
+ let rev_exns =
+ ("Internal_error",Some <:ctyp< string >>) ::
+ ("Message_param_count_mismatch",Some <:ctyp< (string * int * int) >>) ::
+ ("Unknown_RPC",Some <:ctyp< string >>) :: rev_exns in
let rpcs = List.rev rev_rpcs in
let rec flatten_rpcs rpcs =
List.flatten (List.map (function
| Rpc r -> [r]
| Namespace (rs,rpcs) -> flatten_rpcs rpcs) rpcs)
in
- let failure_bits =
- let failure_ctyp = <:ctyp< (string * list (string * string)) >> in
+ let (tydecls,_) = List.fold_left
+ (fun (decls,i) (uid,ty) ->
+ let tyname = Printf.sprintf "__exn_ty%d" i in
+ match ty with
+ | Some ty ->
+ (<:str_item< type $lid:tyname$ = $ty$; >> :: decls , i+1)
+ | None ->
+ (decls,i+1)) ([],0) rev_exns in
+
+ let (exceptions,_) = List.fold_left
+ (fun (exns,i) (uid,ty) ->
+ let tyname = Printf.sprintf "__exn_ty%d" i in
+ match ty with
+ | Some ty ->
+ (<:str_item< exception $uid:uid$ of $lid:tyname$ >> :: exns, i+1)
+ | None ->
+ (<:str_item< exception $uid:uid$ >> :: exns, i+1)) ([],0) rev_exns in
+
+ let exnty = <:ctyp< [ $Ast.tyOr_of_list
+ (List.map (fun (uid,ty) ->
+ match ty with
+ | Some ty -> <:ctyp< $uid:uid$ of $ty$ >>
+ | None -> <:ctyp< $uid:uid$ >>) rev_exns)$ ] >> in
+
+ let exns = <:str_item< module Exception = struct type exnty = $exnty$ ;
+ value $MyRpc.Rpc_of.gen_one ("exnty",[],exnty)$;
+ value $MyRpc.Of_rpc.gen_one ("exnty",[],exnty)$;
+ end >> in
+
+ let exnty_of_exn =
+ let gen_mc (uid,ty) = <:match_case<
+ $uid:uid$ x -> Exception.$uid:uid$ x >> in
+ let generic = <:match_case<
+ e -> Exception.Internal_error (Printexc.to_string e) >> in
+ let ors = List.map gen_mc rev_exns in
<:str_item<
- type failure = $failure_ctyp$;
- value $MyRpc.Rpc_of.gen_one ("failure",[],failure_ctyp)$;
- value $MyRpc.Of_rpc.gen_one ("failure",[],failure_ctyp)$;
- exception RpcFailure of (string * list (string * string))
- >>
+ value exnty_of_exn x = match x with [ $Ast.mcOr_of_list (ors @ [generic])$ ] >>
in
+
+ let exn_of_exnty =
+ let gen_mc (uid,ty) = <:match_case<
+ Exception.$uid:uid$ x -> $uid:uid$ x >> in
+ let ors = List.map gen_mc rev_exns in
+ <:str_item<
+ value exn_of_exnty x = match x with [ $Ast.mcOr_of_list ors$ ] >>
+ in
+
let rpc_type =
let t = <:ctyp< Rpc.call -> Rpc.response >> in
let s = <:sig_item< value rpc: $typ:t$ >> in
@@ -327,7 +379,11 @@ struct
let flat_rpcs = flatten_rpcs rpcs in
let sis = Ast.list_of_str_item si [] in
<:str_item< $list: (List.map filter_types sis) @
- [ failure_bits;
+ tydecls @
+ exceptions @
+ [ exns;
+ exnty_of_exn;
+ exn_of_exnty;
make_args rpcs;
rpc_type;
make_client rpcs;

0 comments on commit eb9be87

Please sign in to comment.