[rpc-light] implements {call,response}_of_string and string_of_{call,response} for...

Now, need to do the same thing for JSON.

Signed-off-by: Thomas Gazagnaire <thomas.gazagnaire@citrix.com>

diff --git a/rpc-light/examples/all_types.ml b/rpc-light/examples/all_types.ml
index c11cd73985376ebb340511fe5afd147389a35261..1f9d757429c20b31fbfef80ff297da130c720e7d 100644 (file)
--- a/rpc-light/examples/all_types.ml
+++ b/rpc-light/examples/all_types.ml
@@ -55,5 +55,22 @@ let _ =
        let x2 = x_of_rpc (Xmlrpc.of_string ~callback xml) in
        let x3 = x_of_rpc (Jsonrpc.of_string json) in
 
-       Printf.printf "\nSanity check:\nx1=x2: %b\nx2=x3: %b\nx1=x3: %b\n\n" (x1 = x2) (x2 = x3) (x1 = x3)
+       Printf.printf "\nSanity check:\nx1=x2: %b\nx2=x3: %b\nx1=x3: %b\n\n" (x1 = x2) (x2 = x3) (x1 = x3);
        
+       let call = { Rpc.name = "foo"; Rpc.params = [ rpc ] } in
+       let response1 = Rpc.Success rpc in
+       let response2 = Rpc.Fault (1L, "Foo") in
+
+       let c1 = Xmlrpc.string_of_call call in
+       let r1 = Xmlrpc.string_of_response response1 in
+       let r2 = Xmlrpc.string_of_response response2 in
+
+       Printf.printf "call: %s\n" c1;
+       Printf.printf "response1: %s\n" r1; 
+       Printf.printf "response2: %s\n" r2; 
+
+       let c1' = Xmlrpc.call_of_string c1 in
+       let r1' = Xmlrpc.response_of_string r1 in
+       let r2' = Xmlrpc.response_of_string r2 in
+       Printf.printf "\nSanity check:\ncall=c1': %b\nresponse1=r1': %b\nresponse2=r2': %b\n"
+               (call = c1') (response1 = r1') (response2 = r2')

diff --git a/rpc-light/rpc.ml b/rpc-light/rpc.ml
index 9db3c49b523feaff023160019ca9430d918fdcc3..775e95185cf9962460167ab80259f846e0bdd272 100644 (file)
--- a/rpc-light/rpc.ml
+++ b/rpc-light/rpc.ml
@@ -51,4 +51,4 @@ type call = {
 
 type response =
        | Success of Val.t
-       | Fault of int * string
+       | Fault of int64 * string

diff --git a/rpc-light/xmlrpc.ml b/rpc-light/xmlrpc.ml
index 2a0a58aebd0fabc778665f849a94ed82954f12f3..61e52e35355118612d41d96f9a81ce41b299236e 100644 (file)
--- a/rpc-light/xmlrpc.ml
+++ b/rpc-light/xmlrpc.ml
@@ -76,6 +76,40 @@ let to_string x =
        add_value (Buffer.add_string buf) x;
        Buffer.contents buf
 
+let string_of_call call =
+       let module B = Buffer in
+       let buf = B.create 1024 in
+       let add = B.add_string buf in
+       add "<?xml version=\"1.0\"?>";
+       add "<methodCall><methodName>";
+       add (check call.Rpc.name);
+       add "</methodName><params>";
+       List.iter (fun p ->
+               add "<param>";
+               add (to_string p);
+               add "</param>"
+               ) call.Rpc.params;
+       add "</params></methodCall>";
+       B.contents buf
+
+let string_of_response response =
+       let module B = Buffer in
+       let buf = B.create 256 in
+       let add = B.add_string buf in
+       begin match response with
+       | Rpc.Success v   ->
+               add "<?xml version=\"1.0\"?><methodResponse><params><param>";
+               add (to_string v);
+               add "</param></params></methodResponse>";
+       | Rpc.Fault (i,s) ->
+               add "<?xml version=\"1.0\"?><methodResponse><fault><value><struct><member><name>faultCode</name><value><int>";
+               add (Int64.to_string i);
+               add "</int></value></member><member><name>faultString</name><value><string>";
+               add s;
+               add "</string></value></member></struct></value></fault></methodResponse>";
+       end;
+       B.contents buf
+
 exception Parse_error of string * Xmlm.signal * Xmlm.input
 
 let debug_signal = function
@@ -207,7 +241,11 @@ module Parser = struct
 
        (* General parser functions *)
        let rec of_xml ?callback accu input =
-               value (map_tags (basic_types ?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);
+                       exit (-1)
+                       | e -> Printf.eprintf "%s\n%!" (Printexc.to_string e); exit (-1)
 
        and basic_types ?callback accu input = function
                | "int" | "i4" -> make_int    ?callback accu (get_data input)
@@ -233,3 +271,42 @@ let of_string ?callback str : Rpc.Val.t =
        | _      -> () end;
        Parser.of_xml ?callback [] input
        
+let call_of_string ?callback str : Rpc.call =
+       let input = Xmlm.make_input (`String (0, str)) in
+       begin match Xmlm.peek input with
+       | `Dtd _ -> ignore (Xmlm.input input)
+       | _      -> () end;
+       let name = ref "" in
+       let params = ref [] in
+       Parser.map_tag "methodCall" (fun input ->
+               name := Parser.map_tag "methodName" Parser.get_data input;
+               Parser.map_tag "params" (fun input ->
+                       while Xmlm.peek input <> `El_end do
+                               Parser.map_tag "param" (fun input -> params := (Parser.of_xml ?callback [] input) :: !params) input
+                       done;
+                       ) input
+               ) input;
+       { Rpc.name = !name; Rpc.params = !params }
+       
+let response_of_string ?callback str : Rpc.response =
+       let input = Xmlm.make_input (`String (0, str)) in
+       begin match Xmlm.peek input with
+       | `Dtd _ -> ignore (Xmlm.input input)
+       | _      -> () end;
+       Parser.map_tag "methodResponse" (fun input ->
+               match Xmlm.peek input with
+               | `El_start ((_,"fault"),_) ->
+                       Parser.map_tag "fault" (fun input ->
+                               let signal = Xmlm.peek input in
+                               match Parser.of_xml ?callback [] input with
+                                       | `Dict [ "faultCode", `Int i; "faultString", `String s ] -> Rpc.Fault (i, s)
+                                       | s -> parse_error (to_string s) signal input
+                               ) input
+               | `El_start ((_,"params"),_) ->
+                       Parser.map_tag "params" (fun input ->
+                               Parser.map_tag "param" (fun input -> Rpc.Success (Parser.of_xml ?callback [] input)) input
+                               ) input
+               | s -> parse_error "response" s input
+               ) input 
+
+       

diff --git a/rpc-light/xmlrpc.mli b/rpc-light/xmlrpc.mli
index 6def312e0144957cc9603ef82687e3bb76b03c57..4643ec27ebba630dd6cb300ad6619280913120e1 100644 (file)
--- a/rpc-light/xmlrpc.mli
+++ b/rpc-light/xmlrpc.mli
@@ -14,3 +14,9 @@
 
 val to_string : Rpc.Val.t -> string
 val of_string : ?callback:Rpc.callback -> string -> Rpc.Val.t
+
+val string_of_call: Rpc.call -> string
+val call_of_string: ?callback:Rpc.callback -> string -> Rpc.call
+
+val string_of_response: Rpc.response -> string
+val response_of_string: ?callback:Rpc.callback -> string -> Rpc.response