[rpc-light] Add a function to marshal and unmarshal XMLRPC to a bigbuffer

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

diff --git a/rpc-light/xmlrpc.ml b/rpc-light/xmlrpc.ml
index 85f2461ab69da8e81d49aeecfaca1b87e280c87a..bb3ad88c349fa32387baa7e0d218b18dffc4a1f8 100644 (file)
--- a/rpc-light/xmlrpc.ml
+++ b/rpc-light/xmlrpc.ml
@@ -77,6 +77,11 @@ let to_string x =
        add_value (Buffer.add_string buf) x;
        Buffer.contents buf
 
+let to_a ~empty ~append x =
+       let buf = empty () in
+       add_value (fun s -> append buf s) x;
+       buf
+
 let string_of_call call =
        let module B = Buffer in
        let buf = B.create 1024 in
@@ -103,6 +108,15 @@ let string_of_response response =
        add "</param></params></methodResponse>";
        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>";
+       buf
+
 exception Parse_error of string * Xmlm.signal * Xmlm.input
 
 let debug_signal = function
@@ -141,8 +155,10 @@ let debug_input input =
        aux [];
        Buffer.contents buf
 
+let pretty_string_of_error (n,s,i) =
+       Printf.sprintf "Error: got '%s' while '%s' was expected when processing '%s'\n" (debug_signal s) n (debug_input i)
+
 let parse_error n s i =
-       Printf.eprintf "Error: got '%s' while '%s' was expected when processing '%s'\n" (debug_signal s) n (debug_input i);
        raise (Parse_error (n,s,i))
 
 module Parser = struct
@@ -153,9 +169,13 @@ module Parser = struct
                | `Data d -> d
                | e       -> parse_error "..." e input
 
-       let open_tag input =
+       let rec open_tag input =
                match Xmlm.input input with
                | `El_start ((_,tag),_) -> tag
+               | `Data s
+                       when s = " " 
+                       || s = "\n" 
+                       || s = "\t"         -> open_tag input
                | e                     -> parse_error "<...>" e input
 
        let close_tag input =
@@ -241,7 +261,16 @@ let of_string ?callback str =
        | `Dtd _ -> ignore (Xmlm.input input)
        | _      -> () end;
        Parser.of_xml ?callback [] input
-       
+
+let of_a ?callback ~next_char b =
+       let aux () =
+               try 
+                       let c = next_char b in
+                       int_of_char c
+               with _ -> raise End_of_file in
+       let input = Xmlm.make_input (`Fun aux) in
+       Parser.of_xml ?callback [] input
+
 let call_of_string ?callback str =
        let input = Xmlm.make_input (`String (0, str)) in
        begin match Xmlm.peek input with

diff --git a/rpc-light/xmlrpc.mli b/rpc-light/xmlrpc.mli
index 89b7fc4d161e010bb3a044805ba3b16a4cb1c0e6..fb562f4c57d8be8f62ef714b886fdcd7fe74e2ad 100644 (file)
--- a/rpc-light/xmlrpc.mli
+++ b/rpc-light/xmlrpc.mli
@@ -15,10 +15,14 @@
 val to_string : Rpc.t -> string
 val of_string : ?callback:Rpc.callback -> string -> Rpc.t
 
+val to_a : empty:(unit -> 'a) -> append:('a -> string -> unit) -> Rpc.t -> 'a
+val of_a : ?callback:Rpc.callback -> next_char:('a  -> char) -> 'a -> Rpc.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 a_of_response : empty:(unit -> 'a) -> append:('a -> string -> unit) -> Rpc.response -> 'a
 
 val response_of_string: ?callback:Rpc.callback -> string -> Rpc.response
 val response_of_in_channel: ?callback:Rpc.callback -> in_channel -> Rpc.response