# 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 =