# HG changeset patch
# User Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
# Date 1262958466 0
# Node ID 908be71d7e00c6ebedb89a674276686cd62ec433
# Parent 009c14391cf870a2a283973727c7b839250b813e
[rpc-light] XMLRPC fault need to be parsed correctly
Moreover, in case of complex return value v when we have an error, apply the
xapi policy which is to create a structure { Status : Failure; ErrorDescription
: v }. When unmarshalling the XMLRPC, if we got { Status : Success; Value: v },
then it is equivalent to v. This is sufficiently flexible to discuss with the
SM backend and xapi (which have different conventions).
Signed-off-by: Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
diff -r 009c14391cf8 -r 908be71d7e00 rpc-light/examples/Makefile
--- a/rpc-light/examples/Makefile Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/examples/Makefile Fri Jan 08 13:47:46 2010 +0000
@@ -7,7 +7,8 @@
all_types \
phantom \
xapi \
- option
+ option \
+ encoding
EXECS=$(foreach example, $(EXAMPLES), $(example).opt)
diff -r 009c14391cf8 -r 908be71d7e00 rpc-light/examples/encoding.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/rpc-light/examples/encoding.ml Fri Jan 08 13:47:46 2010 +0000
@@ -0,0 +1,11 @@
+type t = string with rpc
+
+let _ =
+ let t = "<provision><value><int>4</int></value>" in
+ let r = rpc_of_t t in
+ Printf.printf "r = %s\n%!" (Rpc.to_string r);
+
+ let t' = t_of_rpc r in
+ Printf.printf "t = t : %b'\n%!" (t = t');
+ assert (t = t')
+
diff -r 009c14391cf8 -r 908be71d7e00 rpc-light/examples/xapi.ml
--- a/rpc-light/examples/xapi.ml Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/examples/xapi.ml Fri Jan 08 13:47:46 2010 +0000
@@ -1,3 +1,37 @@
+let simple_call =
+"<methodCall>
+ <methodName>session.login_with_password</methodName>
+ <params>
+ <param>
+ <value/>
+ </param>
+ <param>
+ <value/>
+ </param>
+ <param>
+ <value>1.4</value>
+ </param>
+ </params>
+</methodCall>
+"
+
+let error =
+"<methodResponse>
+<fault>
+<value><struct>
+<member>
+<name>faultCode</name>
+<value><int>143</int></value>
+</member>
+<member>
+<name>faultString</name>
+<value><string>Failed to parse the request</string></value>
+</member>
+</struct></value>
+</fault>
+</methodResponse>
+"
+
let sm =
"<?xml version='1.0'?>
<methodResponse>
@@ -74,5 +108,11 @@
Printf.printf "OK\nParsing empty tags ... %!";
Xmlrpc.of_string empty;
+ Printf.printf "OK\nParsing error ... %!";
+ Xmlrpc.response_of_string error;
+
+ Printf.printf "OK\nParsing simple call ... %!";
+ Xmlrpc.call_of_string simple_call;
+
Printf.printf "OK\n%!"
diff -r 009c14391cf8 -r 908be71d7e00 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
@@ -98,23 +98,26 @@
add "</params></methodCall>";
B.contents buf
+let add_response add response =
+ let v = if response.success then
+ Dict [ "Status", String "Success"; "Value", response.contents ]
+ else
+ Dict [ "Status", String "Failure"; "ErrorDescription",
response.contents ] in
+ add "<?xml version=\"1.0\"?><methodResponse><params><param>";
+ add (to_string v);
+ add "</param></params></methodResponse>"
+
let string_of_response response =
let module B = Buffer in
let buf = B.create 256 in
let add = B.add_string buf in
- let v = if response.success then response.contents else Dict [
"failure", response.contents ] in
- add "<?xml version=\"1.0\"?><methodResponse><params><param>";
- add (to_string v);
- add "</param></params></methodResponse>";
+ add_response add response;
B.contents buf
let a_of_response ~empty ~append response =
let buf = empty () in
let add s = append buf s in
- let v = if response.success then response.contents else Dict [
"failure", response.contents ] in
- add "<?xml version=\"1.0\"?><methodResponse><params><param>";
- add (to_string v);
- add "</param></params></methodResponse>";
+ add_response add response;
buf
exception Parse_error of string * string * Xmlm.input
@@ -219,7 +222,7 @@
close_tag tag input;
r
end else
- parse_error (sprintf "open_tag(%s)" t) (sprintf
"open_tag(%s)" t) input
+ parse_error (sprintf "open_tag(%s)" t) (sprintf
"open_tag(%s)" tag) input
let name input = map_tag "name" get_data input
let data f input = map_tag "data" f input
@@ -283,13 +286,13 @@
and basic_types ?callback accu input = function
| "int"
| "i4" -> make_int ?callback accu (get_data input)
- | "boolean" -> make_bool ?callback accu (get_data input)
+ | "boolean"-> make_bool ?callback accu (get_data input)
| "double" -> make_float ?callback accu (get_data input)
| "string" -> make_string ?callback accu (get_data input)
| "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 (sprintf "open_tag(%s)" tag)
"open_tag(int/i4/bool/double/string/array/struct/nil" input
+ | tag -> parse_error (sprintf "open_tag(%s)" tag)
"open_tag(int/i4/boolean/double/string/array/struct/nil)" input
and of_xmls ?callback accu input =
let r = ref [] in
@@ -333,21 +336,47 @@
Parser.skip_empty input;
done;
) input
- ) input;
+ ) input;
call !name (List.rev !params)
-
+
+let response_of_fault ?callback input =
+ Parser.map_tag "fault" (fun input ->
+ match Parser.of_xml ?callback [] input with
+ | Dict d ->
+ let fault_code = List.assoc "faultCode" d in
+ let fault_string = List.assoc "faultString" d in
+ failure ( Rpc.Enum [ String "fault"; fault_code;
fault_string ] )
+ | r -> parse_error (to_string r) "fault" input
+ ) input
+
+let response_of_success ?callback input =
+ Parser.map_tag "params" (fun input ->
+ Parser.map_tag "param" (fun input ->
+ match Parser.of_xml ?callback [] input with
+ | Dict d ->
+ if List.mem_assoc "Status" d && List.assoc
"Status" d = String "Success" && List.mem_assoc "Value" d then
+ success (List.assoc "Value" d)
+ else if List.mem_assoc "Status" d && List.assoc
"Status" d = String "Failure" && List.mem_assoc "ErrorDescription" d then
+ failure (List.assoc "ErrorDescription"
d)
+ else
+ success (Dict d)
+ | v -> success v
+ ) input
+ ) input
+
let response_of_input ?callback input =
begin match Xmlm.peek input with
| `Dtd _ -> ignore (Xmlm.input input)
| _ -> () end;
Parser.map_tag "methodResponse" (fun input ->
- Parser.map_tag "params" (fun input ->
- Parser.map_tag "param" (fun input ->
- match Parser.of_xml ?callback [] input with
- | Dict [ "failure", v ] -> failure v
- | v -> success v
- ) input
- ) input
+ Parser.skip_empty input;
+ match Xmlm.peek input with
+ | `El_start ((_,"params"),_) -> response_of_success ?callback
input
+ | `El_start ((_,"fault"),_) -> response_of_fault ?callback
input
+ | `El_start ((_,tag),_) -> parse_error (sprintf
"open_tag(%s)" tag) "open_tag(fault/params)" input
+ | `Data d -> parse_error (String.escaped d)
"open_tag(fault/params)" input
+ | `El_end -> parse_error "close_tag"
"open_tag(fault/params)" input
+ | `Dtd _ -> parse_error "dtd"
"open_tag(fault/params)" input
) input
let response_of_string ?callback str =
4 files changed, 102 insertions(+), 21 deletions(-)
rpc-light/examples/Makefile | 3 +
rpc-light/examples/encoding.ml | 11 ++++++
rpc-light/examples/xapi.ml | 40 +++++++++++++++++++++++
rpc-light/xmlrpc.ml | 69 ++++++++++++++++++++++++++++------------
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