# HG changeset patch # User Thomas Gazagnaire <[email protected]> # Date 1262958466 0 # Node ID 67078f88291e9970dc3ca0c43ae3ba28c8c20a0a # Parent 90fd186e17ef6bc1193681c157a6fa683be7b668 [rpc-light] Add a function to marshal and unmarshal XMLRPC to a bigbuffer
Signed-off-by: Thomas Gazagnaire <[email protected]> diff -r 90fd186e17ef -r 67078f88291e 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 @@ -77,6 +77,11 @@ 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 @@ -102,6 +107,15 @@ add (to_string v); 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 @@ -141,8 +155,10 @@ 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 @@ | `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 @@ | `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 -r 90fd186e17ef -r 67078f88291e rpc-light/xmlrpc.mli --- a/rpc-light/xmlrpc.mli Fri Jan 08 13:47:46 2010 +0000 +++ b/rpc-light/xmlrpc.mli Fri Jan 08 13:47:46 2010 +0000 @@ -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 2 files changed, 36 insertions(+), 3 deletions(-) rpc-light/xmlrpc.ml | 35 ++++++++++++++++++++++++++++++++--- rpc-light/xmlrpc.mli | 4 ++++
# HG changeset patch # User Thomas Gazagnaire <[email protected]> # Date 1262958466 0 # Node ID 67078f88291e9970dc3ca0c43ae3ba28c8c20a0a # Parent 90fd186e17ef6bc1193681c157a6fa683be7b668 [rpc-light] Add a function to marshal and unmarshal XMLRPC to a bigbuffer Signed-off-by: Thomas Gazagnaire <[email protected]> diff -r 90fd186e17ef -r 67078f88291e 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 @@ -77,6 +77,11 @@ 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 @@ -102,6 +107,15 @@ add (to_string v); 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 @@ -141,8 +155,10 @@ 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 @@ | `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 @@ | `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 -r 90fd186e17ef -r 67078f88291e rpc-light/xmlrpc.mli --- a/rpc-light/xmlrpc.mli Fri Jan 08 13:47:46 2010 +0000 +++ b/rpc-light/xmlrpc.mli Fri Jan 08 13:47:46 2010 +0000 @@ -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
_______________________________________________ xen-api mailing list [email protected] http://lists.xensource.com/mailman/listinfo/xen-api
