[Xen-API] [PATCH 09 of 17] [rpc-light] Add some friendly error messages on runtime errors

[Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>]

# HG changeset patch
# User Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
# Date 1262958466 0
# Node ID 9b6f70f647a5f668f348143f1c3a19a13d8b85e8
# Parent  67078f88291e9970dc3ca0c43ae3ba28c8c20a0a
[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@xxxxxxxxxx>

diff -r 67078f88291e -r 9b6f70f647a5 rpc-light/rpc.ml
--- a/rpc-light/rpc.ml  Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/rpc.ml  Fri Jan 08 13:47:46 2010 +0000
@@ -79,10 +79,16 @@
 
 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 -r 67078f88291e -r 9b6f70f647a5 rpc-light/rpc.mli
--- a/rpc-light/rpc.mli Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/rpc.mli Fri Jan 08 13:47:46 2010 +0000
@@ -59,9 +59,13 @@
 
 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 -r 67078f88291e -r 9b6f70f647a5 rpc-light/xmlrpc.ml
--- a/rpc-light/xmlrpc.ml       Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/xmlrpc.ml       Fri Jan 08 13:47:46 2010 +0000
@@ -117,13 +117,7 @@
        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 @@
        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
+               | `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 close_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 @@
        (* 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 @@
                | "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
3 files changed, 43 insertions(+), 28 deletions(-)
rpc-light/rpc.ml    |    6 +++++
rpc-light/rpc.mli   |    4 +++
rpc-light/xmlrpc.ml |   61 +++++++++++++++++++++++++++------------------------

Attachment: xen-api-libs.hg-17.patch
Description: Text Data

_______________________________________________
xen-api mailing list
xen-api@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/mailman/listinfo/xen-api