# 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 +++++++++++++++++++++++++++------------------------
xen-api-libs.hg-17.patch
Description: Text Data
_______________________________________________
xen-api mailing list
xen-api@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/mailman/listinfo/xen-api
|
Home