[rpc-light] Add some explicit runtime exceptions when an runtime error occurs.

A friendly error message is displayed as well if Rpc.set_debug true is called before.

Signed-off-by: Thomas Gazagnaire <thomas.gazagnaire@citrix.com>

diff --git a/rpc-light/p4_rpc.ml b/rpc-light/p4_rpc.ml
index 541e0db37b136f8ba975c506e03a44782447a98d..763c75027ae017c58e7ad438641a2c909cca8f95 100644 (file)
--- a/rpc-light/p4_rpc.ml
+++ b/rpc-light/p4_rpc.ml
@@ -103,7 +103,6 @@ let new_id _loc =
 let new_id_list _loc l =
        List.split (List.map (fun _ -> new_id _loc) l)
 
-exception Type_not_supported of ctyp
 let type_not_supported ty =
        let module PP = Camlp4.Printers.OCaml.Make(Syntax) in
        let pp = new PP.printer () in
@@ -216,121 +215,126 @@ module Of_rpc = struct
 
        let str_of_id id = match id with <:expr@loc< $lid:s$ >> -> <:expr@loc< $str:s$ >> | _ -> assert false
 
-       let runtime_error id expected =
+       let runtime_error name id expected =
                let _loc = Loc.ghost in
-               <:match_case<  __x__ ->
-                       failwith (Printf.sprintf "Runtime error while parsing '%s': got '%s' while '%s' was expected\\n" $str_of_id id$ (Rpc.to_string __x__) $str:expected$)
+               <:match_case<  __x__ -> do {
+                       if Rpc.get_debug () then
+                               Printf.eprintf "Runtime error in '%s_of_rpc:%s': got '%s' when '%s' was expected\\n" $str:name$ $str_of_id id$ (Rpc.to_string __x__) $str:expected$
+                       else ();
+                       raise (Rpc.Runtime_error ($str:expected$, __x__)) }
                >>
 
-       let runtime_exn_error id doing =
+       let runtime_exn_error name id doing =
                let _loc = Loc.ghost in
-               <:match_case< __x__ ->
-                       failwith (Printf.sprintf "Runtime error while parsing '%s': got exception '%s' while doing '%s'\\n" $str_of_id id$ (Printexc.to_string __x__) $str:doing$)
-               >>
+               <:match_case< __x__ -> do {
+                       if Rpc.get_debug () then
+                               Printf.eprintf "Runtime error in '%s_of_rpc:%s': caught exception '%s' while doing '%s'\\n" $str:name$ $str_of_id id$ (Printexc.to_string __x__) $str:doing$
+                       else () ;
+                       raise (Rpc.Runtime_exception ($str:doing$, Printexc.to_string __x__)) }         >>
 
-       let rec create id ctyp =
+       let rec create name id ctyp =
                let _loc = loc_of_ctyp ctyp in
                match ctyp with
-               | <:ctyp< unit >>   -> <:expr< match $id$ with [ Rpc.Null -> () | $runtime_error id "Null"$ ] >>
+               | <:ctyp< unit >>   -> <:expr< match $id$ with [ Rpc.Null -> () | $runtime_error name id "Null"$ ] >>
 
                | <:ctyp< int >>    ->
                        <:expr< match $id$ with [
                          Rpc.Int x    -> Int64.to_int x
                        | Rpc.String s -> int_of_string s
-                       | $runtime_error id "Int(int)"$ ] >>
+                       | $runtime_error name id "Int(int)"$ ] >>
 
                | <:ctyp< int32 >>  ->
                        <:expr< match $id$ with [
                          Rpc.Int x    -> Int64.to_int32 x
                        | Rpc.String s -> Int32.of_string s
-                       | $runtime_error id "Int(int32)"$ ] >>
+                       | $runtime_error name id "Int(int32)"$ ] >>
 
                | <:ctyp< int64 >>  ->
                        <:expr< match $id$ with [
                          Rpc.Int x    -> x
                        | Rpc.String s -> Int64.of_string s
-                       | $runtime_error id "Int(int64)"$ ] >>
+                       | $runtime_error name id "Int(int64)"$ ] >>
 
                | <:ctyp< float >>  ->
                        <:expr< match $id$ with [
                          Rpc.Float x  -> x
                        | Rpc.String s -> float_of_string s
-                       | $runtime_error id "Float"$ ] >>
+                       | $runtime_error name id "Float"$ ] >>
 
                | <:ctyp< char >>   ->
                        <:expr< match $id$ with [
                          Rpc.Int x    -> Char.chr (Int64.to_int x)
                        | Rpc.String s -> Char.chr (int_of_string s)
-                       | $runtime_error id "Int(char)"$ ] >>
+                       | $runtime_error name id "Int(char)"$ ] >>
 
-               | <:ctyp< string >> -> <:expr< match $id$ with [ Rpc.String x -> x | $runtime_error id "String(string)"$ ] >>
-               | <:ctyp< bool >>   -> <:expr< match $id$ with [ Rpc.Bool x -> x | $runtime_error id "Bool"$ ] >>
+               | <:ctyp< string >> -> <:expr< match $id$ with [ Rpc.String x -> x | $runtime_error name id "String(string)"$ ] >>
+               | <:ctyp< bool >>   -> <:expr< match $id$ with [ Rpc.Bool x -> x | $runtime_error name id "Bool"$ ] >>
 
                | <:ctyp< [< $t$ ] >> | <:ctyp< [> $t$ ] >> | <:ctyp< [= $t$ ] >> | <:ctyp< [ $t$ ] >> ->
                        let ids, ctyps = decompose_variants _loc t in
                        let pattern (n, t) ctyps =
                                let ids, pids = new_id_list _loc ctyps in
                                let patt = <:patt< Rpc.Enum [ Rpc.String $str:n$ :: $patt_list_of_list _loc pids$ ] >> in
-                               let exprs = List.map2 create ids ctyps in
+                               let exprs = List.map2 (create name) ids ctyps in
                                let body = List.fold_right
                                        (fun a b -> <:expr< $b$ $a$ >>)
                                        (List.rev exprs)
                                        (if t = `V then <:expr< $uid:n$ >> else <:expr< `$uid:n$ >>) in
                                <:match_case< $patt$ -> $body$ >> in
-                       let fail_match = <:match_case< $runtime_error id "Enum[String s;...]"$ >> in
+                       let fail_match = <:match_case< $runtime_error name id "Enum[String s;...]"$ >> in
                        let patterns = mcOr_of_list (List.map2 pattern ids ctyps @ [ fail_match ]) in
                        <:expr< match $id$ with [ $patterns$ ] >>
 
                | <:ctyp< option $t$ >> ->
                        let nid, npid = new_id _loc in
-                       <:expr< match $id$ with [ Rpc.Enum [] -> None | Rpc.Enum [ $npid$ ] -> Some $create nid t$ | $runtime_error id "Enum[]/Enum[_]"$ ] >>
+                       <:expr< match $id$ with [ Rpc.Enum [] -> None | Rpc.Enum [ $npid$ ] -> Some $create name nid t$ | $runtime_error name id "Enum[]/Enum[_]"$ ] >>
 
                | <:ctyp< $tup:tp$ >> ->
                        let ctyps = list_of_ctyp tp [] in
                        let ids, pids = new_id_list _loc ctyps in
-                       let exprs = List.map2 create ids ctyps in
+                       let exprs = List.map2 (create name) ids ctyps in
                        <:expr< match $id$ with
-                               [ Rpc.Enum $patt_list_of_list _loc pids$ -> $expr_tuple_of_list _loc exprs$ | $runtime_error id "List"$ ]
+                               [ Rpc.Enum $patt_list_of_list _loc pids$ -> $expr_tuple_of_list _loc exprs$ | $runtime_error name id "List"$ ]
                        >>
 
                | <:ctyp< list $t$ >> ->
                        let nid, npid = new_id _loc in
                        let nid2, npid2 = new_id _loc in
                        <:expr< match $id$ with
-                               [ Rpc.Enum $npid$ -> List.map (fun $npid2$ -> $create nid2 t$) $nid$ | $runtime_error id "List"$ ]
+                               [ Rpc.Enum $npid$ -> List.map (fun $npid2$ -> $create name nid2 t$) $nid$ | $runtime_error name id "List"$ ]
                        >>
 
                | <:ctyp< array $t$ >> ->
                        let nid, npid = new_id _loc in
                        let nid2, npid2 = new_id _loc in
                        <:expr< match $id$ with
-                               [ Rpc.Enum $npid$ -> Array.of_list (List.map (fun $npid2$ -> $create nid2 t$) $nid$) | $runtime_error id "List"$ ]
+                               [ Rpc.Enum $npid$ -> Array.of_list (List.map (fun $npid2$ -> $create name nid2 t$) $nid$) | $runtime_error name id "List"$ ]
                        >>
 
                | <:ctyp< { $t$ } >> ->
                        let nid, npid = new_id _loc in
                        let fields = decompose_fields _loc t in
                        let ids, pids = new_id_list _loc fields in
-                       let exprs = List.map2 (fun id (n, ctyp) -> <:rec_binding< $lid:n$ = $create id ctyp$ >>) ids fields in
+                       let exprs = List.map2 (fun id (n, ctyp) -> <:rec_binding< $lid:n$ = $create name id ctyp$ >>) ids fields in
                        let bindings =
                                List.map2 (fun pid (n, ctyp) ->
-                                       <:binding< $pid$ = try List.assoc $str:n$ $nid$ with [ $runtime_exn_error nid ("Looking for key "^n)$ ] >>
+                                       <:binding< $pid$ = try List.assoc $str:n$ $nid$ with [ $runtime_exn_error name nid ("Looking for key "^n)$ ] >>
                                        ) pids fields in
                        <:expr< match $id$ with
-                               [ Rpc.Dict $npid$ -> let $biAnd_of_list bindings$ in { $rbSem_of_list exprs$ } | $runtime_error id "Dict"$ ]
+                               [ Rpc.Dict $npid$ -> let $biAnd_of_list bindings$ in { $rbSem_of_list exprs$ } | $runtime_error name id "Dict"$ ]
                        >>
 
                | <:ctyp< < $t$ > >> ->
                        let nid, npid = new_id _loc in
                        let fields = decompose_fields _loc t in
                        let ids, pids = new_id_list _loc fields in
-                       let exprs = List.map2 (fun id (n, ctyp) -> <:class_str_item< method $lid:n$ = $create id ctyp$ >>) ids fields in
+                       let exprs = List.map2 (fun id (n, ctyp) -> <:class_str_item< method $lid:n$ = $create name id ctyp$ >>) ids fields in
                        let bindings =
                                List.map2 (fun pid (n, ctyp) ->
-                                       <:binding< $pid$ = try List.assoc $str:n$ $nid$ with [ $runtime_exn_error nid ("Looking for key "^n)$ ] >>
+                                       <:binding< $pid$ = try List.assoc $str:n$ $nid$ with [ $runtime_exn_error name nid ("Looking for key "^n)$ ] >>
                                        ) pids fields in
                        <:expr< match $id$ with 
-                               [ Rpc.Dict $npid$ -> let $biAnd_of_list bindings$ in object $crSem_of_list exprs$ end | $runtime_error id "Dict"$ ]
+                               [ Rpc.Dict $npid$ -> let $biAnd_of_list bindings$ in object $crSem_of_list exprs$ end | $runtime_error name id "Dict"$ ]
                        >>
 
                | <:ctyp< '$lid:a$ >>             -> <:expr< $lid:of_rpc_polyvar a$ $id$ >>
@@ -338,8 +342,8 @@ module Of_rpc = struct
                | <:ctyp< $lid:t$ >>              -> <:expr< $lid:of_rpc t$ $id$ >>
                | <:ctyp< $id:m$ . $lid:t$ >>     -> <:expr< $id:m$ . $lid:of_rpc t$ $id$ >>
 
-               | <:ctyp< $lid:t$ $a$ >>          -> apply _loc of_rpc of_rpc_i create id None t a
-               | <:ctyp< $id:m$ . $lid:t$ $a$ >> -> apply _loc of_rpc of_rpc_i create id (Some m) t a
+               | <:ctyp< $lid:t$ $a$ >>          -> apply _loc of_rpc of_rpc_i (create name) id None t a
+               | <:ctyp< $id:m$ . $lid:t$ $a$ >> -> apply _loc of_rpc of_rpc_i (create name) id (Some m) t a
 
                | _ -> type_not_supported ctyp
 
@@ -349,7 +353,7 @@ module Of_rpc = struct
                <:binding< $lid:of_rpc name$ = 
                        $List.fold_left
                                (fun accu arg -> <:expr< fun $lid:of_rpc_polyvar (name_of_polyvar _loc arg)$ -> $accu$ >>)
-                               (<:expr< fun $pid$ -> $create id ctyp$ >>)
+                               (<:expr< fun $pid$ -> $create name id ctyp$ >>)
                                args$
                >>
 

diff --git a/rpc-light/rpc.ml b/rpc-light/rpc.ml
index 05ffa224c5097bfad1606d57306e940530949e75..380ab3fa72aa49e07347a02dc9197a606f0fb281 100644 (file)
--- a/rpc-light/rpc.ml
+++ b/rpc-light/rpc.ml
@@ -12,6 +12,10 @@
  * GNU Lesser General Public License for more details.
  *)
 
+let debug = ref false
+let set_debug x = debug := x
+let get_debug () = !debug
+
 type t =
        | Int of int64
        | Bool of bool
@@ -21,6 +25,9 @@ type t =
        | Dict of (string * t) list
        | Null
 
+exception Runtime_error of string * t
+exception Runtime_exception of string * string
+
 open Printf
 let map_strings sep fn l = String.concat sep (List.map fn l)
 let rec to_string t = match t with

diff --git a/rpc-light/rpc.mli b/rpc-light/rpc.mli
index d737ac716a80773f89290afcfc8c8fc66a79bf0b..ba12ef7f3757bec32aa711e8b3cf23f77ffd3b00 100644 (file)
--- a/rpc-light/rpc.mli
+++ b/rpc-light/rpc.mli
@@ -56,3 +56,12 @@ type response = { success : bool; contents : t }
 
 val success : t -> response
 val failure : t -> response
+
+(** {2 Run-time errors} *)
+
+exception Runtime_error of string * t
+exception Runtime_exception of string * string
+
+(** {2 Debug options} *)
+val set_debug : bool -> unit
+val get_debug : unit -> bool