[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@citrix.com>

diff --git a/rpc-light/examples/Makefile b/rpc-light/examples/Makefile
index 2578f074e2be32aae3ead54335b9c4eede2e1590..bbfdff4abcf29aba01e275c8081c8ddc1f6155a1 100644 (file)
--- a/rpc-light/examples/Makefile
+++ b/rpc-light/examples/Makefile
@@ -7,7 +7,8 @@ EXAMPLES = \
        all_types \
        phantom \
        xapi \
-       option
+       option \
+       encoding
 
 EXECS=$(foreach example, $(EXAMPLES), $(example).opt)
 

diff --git a/rpc-light/examples/xapi.ml b/rpc-light/examples/xapi.ml
index 54f42f94ef7665d26c37e941dbab3787720b4d34..8708463a633db1604e7087b0f84d7d7704c725e6 100644 (file)
--- a/rpc-light/examples/xapi.ml
+++ b/rpc-light/examples/xapi.ml
@@ -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 @@ let _ =
        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 --git a/rpc-light/xmlrpc.ml b/rpc-light/xmlrpc.ml
index 7f5ed200bc2fa58e000a8deb8e3b1974fa86e258..c17f79f62f8d667669c32da961fbccd15e430dda 100644 (file)
--- a/rpc-light/xmlrpc.ml
+++ b/rpc-light/xmlrpc.ml
@@ -98,23 +98,26 @@ let string_of_call call =
        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 @@ module Parser = struct
                        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 @@ module Parser = struct
        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 @@ let call_of_string ?callback str =
                                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 =