[rpc-light] Add some friendly error messages on runtime errors

This patch defines an exception 'Parse_error of (string * string * input)' when;
- the 1st string is the symbol the parser got
- the 2nd string is the symbol the parser was waiting for

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

diff --git a/rpc-light/rpc.ml b/rpc-light/rpc.ml
index f22f49b83bbc803c45af7fb6fd11b0d392118439..11eae13e9718eedff8b78892deec538253f809c3 100644 (file)
--- a/rpc-light/rpc.ml
+++ b/rpc-light/rpc.ml
@@ -79,10 +79,16 @@ type call = {
 
 let call name params = { name = name; params = params }
 
+let string_of_call call =
+       sprintf "-> %s(%s)" call.name (String.concat "," (List.map to_string call.params))
+
 type response = {
        success: bool;
        contents: t;
 }
 
+let string_of_response response =
+       sprintf "<- %s(%s)" (if response.success then "success" else "failure") (to_string response.contents)
+ 
 let success v = { success = true; contents = v }
 let failure v = { success = false; contents = v }

diff --git a/rpc-light/rpc.mli b/rpc-light/rpc.mli
index 8c7fbcd3818b12e641685d541416e3cbf4c8c02b..cdeff158cf5c8fedf0867a8ab08caf4ea655fa9a 100644 (file)
--- a/rpc-light/rpc.mli
+++ b/rpc-light/rpc.mli
@@ -59,10 +59,14 @@ type call = { name : string; params : t list }
 
 val call : string -> t list -> call
 
+val string_of_call : call -> string
+
 (** {2 Responses} *)
 
 type response = { success : bool; contents : t }
 
+val string_of_response : response -> string
+
 val success : t -> response
 val failure : t -> response
 

diff --git a/rpc-light/xmlrpc.ml b/rpc-light/xmlrpc.ml
index bb3ad88c349fa32387baa7e0d218b18dffc4a1f8..29e0d3eeccfe315d20704e86523ba5197b30ebf0 100644 (file)
--- a/rpc-light/xmlrpc.ml
+++ b/rpc-light/xmlrpc.ml
@@ -117,13 +117,7 @@ let a_of_response ~empty ~append response =
        add "</param></params></methodResponse>";
        buf
 
-exception Parse_error of string * Xmlm.signal * Xmlm.input
-
-let debug_signal = function
-       | `El_start ((_,tag),_) -> Printf.sprintf "<%s>" tag
-       | `El_end               -> "</...>"
-       | `Data d               -> Printf.sprintf "%s" d
-       | `Dtd _                -> "<?dtd?>"
+exception Parse_error of string * string * Xmlm.input
 
 let debug_input input =
        let buf = Buffer.create 1024 in
@@ -155,48 +149,58 @@ let debug_input input =
        aux [];
        Buffer.contents buf
 
-let pretty_string_of_error (n,s,i) =
-       Printf.sprintf "Error: got '%s' while '%s' was expected when processing '%s'\n" (debug_signal s) n (debug_input i)
+let pretty_string_of_error got expected input =
+       sprintf "Error: got '%s' while '%s' was expected when processing '%s'\n" got expected (debug_input input)
 
-let parse_error n s i =
-       raise (Parse_error (n,s,i))
+let parse_error got expected input =
+       raise (Parse_error (got, expected, input))
 
 module Parser = struct
 
        (* Helpers *)
        let get_data input =
                match Xmlm.input input with
-               | `Data d -> d
-               | e       -> parse_error "..." e input
+               | `Dtd _                -> parse_error "dtd" "data" input
+               | `Data d               -> d
+               | `El_start ((_,tag),_) -> parse_error (sprintf "open_tag(%s)" tag) "data" input
+               | `El_end               -> parse_error "close_tag" "data" input
 
        let rec open_tag input =
                match Xmlm.input input with
+               | `Dtd _                -> parse_error "dtd" "open_tag" input
                | `El_start ((_,tag),_) -> tag
-               | `Data s
-                       when s = " " 
-                       || s = "\n" 
-                       || s = "\t"         -> open_tag input
-               | e                     -> parse_error "<...>" e input
-
-       let close_tag input =
+               | `Data d
+                       when d = " " 
+                       || d = "\n" 
+                       || d = "\t"         -> open_tag input
+               | `Data d               -> parse_error (sprintf "data(%s)" (String.escaped d)) "open_tag" input
+               | `El_end               -> parse_error "close_tag" "open_tag" input
+
+       let rec close_tag tag input =
                match Xmlm.input input with
-               | `El_end -> ()
-               | e       -> parse_error "</...>" e input
+               | `Dtd _              -> parse_error "dtd" (sprintf "close_tag(%s)" tag) input
+               | `El_end             -> ()
+               | `El_start ((_,t),_) -> parse_error (sprintf "open_tag(%s)" t) (sprintf "close_tag(%s)" tag) input
+               | `Data d
+                       when d = " "
+                       || d = "\n"
+                       || d = "\t"       -> close_tag tag input
+               | `Data d             -> parse_error (sprintf "data(%s)" (String.escaped d)) (sprintf "close_tag(%s)" tag) input
 
        let map_tags f input =
                let tag = open_tag input in
                let r = f input tag in
-               close_tag input;
+               close_tag tag input;
                r
 
        let map_tag tag f input =
                let t = open_tag input in
                if t = tag then begin
                        let r = f input in
-                       close_tag input;
+                       close_tag tag input;
                        r
                end else
-                       parse_error (Printf.sprintf "<%s>" tag) (`El_start (("",t),[])) input
+                       parse_error (sprintf "open_tag(%s)" t) (sprintf "open_tag(%s)" t) input
 
        let name   input   = map_tag "name" get_data input
        let data   f input = map_tag "data" f input
@@ -231,10 +235,11 @@ module Parser = struct
        (* General parser functions *)
        let rec of_xml ?callback accu input =
                try value (map_tags (basic_types ?callback accu)) input
-               with Xmlm.Error ((a,b), e) ->
-                       Printf.eprintf "Characters %i--%i: %s\n%!" a b (Xmlm.error_message e);
+               with
+               | Xmlm.Error ((a,b), e) ->
+                       eprintf "Characters %i--%i: %s\n%!" a b (Xmlm.error_message e);
                        exit (-1)
-                       | e -> Printf.eprintf "%s\n%!" (Printexc.to_string e); exit (-1)
+               | e -> eprintf "%s\n%!" (Printexc.to_string e); exit (-1)
 
        and basic_types ?callback accu input = function
                | "int"
@@ -245,7 +250,7 @@ module Parser = struct
                | "array"  -> make_enum   ?callback accu (data (of_xmls ?callback accu) input)
                | "struct" -> make_dict   ?callback accu (members (fun name -> of_xml ?callback (name::accu)) input)
                | "nil"    -> make_null   ?callback accu ()
-               | tag      -> parse_error tag (Xmlm.peek input) input
+               | tag      -> parse_error (sprintf "open_tag(%s)" tag) "open_tag(int/i4/bool/double/string/array/struct/nil" input
 
        and of_xmls ?callback accu input =
                let r = ref [] in