Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Fix Xmlrpc.a_of_response such that it doesn't call string_of_*

Also expose json_of_response (Rpc.response -> Rpc.t) which returns
the Rpc.t encoded Jsonrpc response suitable for calling to_string on.

Signed-off-by: Jon Ludlam <jonathan.ludlam@eu.citrix.com>
  • Loading branch information...
commit 3b0f420ed0c548152fbe96b493521f3f79b6efc1 1 parent 9b0abf4
@jonludlam jonludlam authored
Showing with 33 additions and 15 deletions.
  1. +26 −13 rpc-light/jsonrpc.ml
  2. +6 −1 rpc-light/jsonrpc.mli
  3. +1 −1  rpc-light/xmlrpc.ml
View
39 rpc-light/jsonrpc.ml
@@ -67,6 +67,11 @@ let to_string t =
to_buffer t buf;
Buffer.contents buf
+let to_a ~empty ~append t =
+ let buf = empty () in
+ to_fct t (fun s -> append buf s);
+ buf
+
let new_id =
let count = ref 0L in
(fun () -> count := Int64.add 1L !count; !count)
@@ -79,22 +84,28 @@ let string_of_call call =
] in
to_string json
+let json_of_response response =
+ if response.Rpc.success then
+ Dict [
+ "result", response.Rpc.contents;
+ "error", Null;
+ "id", Int 0L
+ ]
+ else
+ Dict [
+ "result", Null;
+ "error", response.Rpc.contents;
+ "id", Int 0L
+ ]
+
let string_of_response response =
- let json =
- if response.Rpc.success then
- Dict [
- "result", response.Rpc.contents;
- "error", Null;
- "id", Int 0L
- ]
- else
- Dict [
- "result", Null;
- "error", response.Rpc.contents;
- "id", Int 0L
- ] in
+ let json = json_of_response response in
to_string json
+let a_of_response ~empty ~append response =
+ let json = json_of_response response in
+ to_a ~empty ~append json
+
type error =
| Unexpected_char of int * char * (* json type *) string
| Invalid_value of int * (* value *) string * (* json type *) string
@@ -481,6 +492,8 @@ module Parser = struct
end
let of_string = Parser.of_string
+let of_a ~next_char b =
+ Parser.of_stream (fun () -> next_char b)
exception Malformed_method_request of string
exception Malformed_method_response of string
View
7 rpc-light/jsonrpc.mli
@@ -15,11 +15,16 @@
val to_string : Rpc.t -> string
val of_string : string -> Rpc.t
+val to_a : empty:(unit -> 'a) -> append:('a -> string -> unit) -> Rpc.t -> 'a
+val of_a : next_char:('a -> char) -> 'a -> Rpc.t
+
val string_of_call: Rpc.call -> string
val call_of_string: string -> Rpc.call
val string_of_response: Rpc.response -> string
-val response_of_string: string -> Rpc.response
+val a_of_response : empty:(unit -> 'a) -> append:('a -> string -> unit) -> Rpc.response -> 'a
+val response_of_string: string -> Rpc.response
+val response_of_in_channel: in_channel -> Rpc.response
View
2  rpc-light/xmlrpc.ml
@@ -135,7 +135,7 @@ let add_response add response =
else
Dict [ "Status", String "Failure"; "ErrorDescription", response.contents ] in
add "<?xml version=\"1.0\"?><methodResponse><params><param>";
- add (to_string v);
+ to_a ~empty:(fun () -> ()) ~append:(fun _ s -> add s) v;
add "</param></params></methodResponse>"
let string_of_response response =
Please sign in to comment.
Something went wrong with that request. Please try again.