# HG changeset patch # User Thomas Gazagnaire <[email protected]> # 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 <[email protected]> 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 +++++++++++++++++++++++++++------------------------
# HG changeset patch # User Thomas Gazagnaire <[email protected]> # 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 <[email protected]> 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
_______________________________________________ xen-api mailing list [email protected] http://lists.xensource.com/mailman/listinfo/xen-api
