# HG changeset patch
# User Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
[rpc-light] implements {call,response}_of_string and string_of_{call,response}
for XMLRPC.
Now, need to do the same thing for JSON.
Signed-off-by: Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
diff -r eb9d6526dec1 rpc-light/examples/all_types.ml
--- a/rpc-light/examples/all_types.ml Thu Dec 10 12:45:59 2009 +0000
+++ b/rpc-light/examples/all_types.ml Fri Dec 11 16:50:23 2009 +0000
@@ -55,5 +55,22 @@
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 -r eb9d6526dec1 rpc-light/rpc.ml
--- a/rpc-light/rpc.ml Thu Dec 10 12:45:59 2009 +0000
+++ b/rpc-light/rpc.ml Fri Dec 11 16:50:23 2009 +0000
@@ -51,4 +51,4 @@
type response =
| Success of Val.t
- | Fault of int * string
+ | Fault of int64 * string
diff -r eb9d6526dec1 rpc-light/xmlrpc.ml
--- a/rpc-light/xmlrpc.ml Thu Dec 10 12:45:59 2009 +0000
+++ b/rpc-light/xmlrpc.ml Fri Dec 11 16:50:23 2009 +0000
@@ -75,6 +75,40 @@
let buf = Buffer.create 128 in
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
@@ -207,7 +241,11 @@
(* 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 @@
| _ -> () 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 -r eb9d6526dec1 rpc-light/xmlrpc.mli
--- a/rpc-light/xmlrpc.mli Thu Dec 10 12:45:59 2009 +0000
+++ b/rpc-light/xmlrpc.mli Fri Dec 11 16:50:23 2009 +0000
@@ -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
txtrELRt8Os7r.txt
Description: Text document
_______________________________________________
xen-api mailing list
xen-api@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/mailman/listinfo/xen-api
|
Home