# HG changeset patch # User Thomas Gazagnaire [rpc-light] add {call,response}_of_string and string_of_{call,response} for JSON as well. Signed-off-by: Thomas Gazagnaire diff -r d85f31ed63ae rpc-light/examples/all_types.ml --- a/rpc-light/examples/all_types.ml Fri Dec 11 16:51:24 2009 +0000 +++ b/rpc-light/examples/all_types.ml Fri Dec 11 17:42:43 2009 +0000 @@ -55,22 +55,36 @@ 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 1:\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 response3 = Rpc.Fault rpc 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; + let cj1 = Jsonrpc.string_of_call call in + let rj1 = Jsonrpc.string_of_response 0L response1 in + let rj3 = Jsonrpc.string_of_response 0L response3 in + + Printf.printf "call: %s\n%s\n" c1 cj1; + Printf.printf "response1: %s\n%s\n" r1 rj1; Printf.printf "response2: %s\n" r2; + Printf.printf "response3: %s\n" rj3; 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') + + Printf.printf "\nSanity check 2:\ncall=c1': %b\nresponse1=r1': %b\nresponse2=r2': %b\n" + (call = c1') (response1 = r1') (response2 = r2'); + + let _, cj1' = Jsonrpc.call_of_string cj1 in + let _, rj1' = Jsonrpc.response_of_string rj1 in + let _, rj3' = Jsonrpc.response_of_string rj3 in + + Printf.printf "\nSanity check 3:\ncall=cj1': %b\nresponse1=rj1': %b\nresponse3=rj3': %b\n" + (call = cj1') (response1 = rj1') (response3 = rj3'); diff -r d85f31ed63ae rpc-light/jsonrpc.ml --- a/rpc-light/jsonrpc.ml Fri Dec 11 16:51:24 2009 +0000 +++ b/rpc-light/jsonrpc.ml Fri Dec 11 17:42:43 2009 +0000 @@ -11,6 +11,8 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) + +open Rpc let rec list_iter_between f o = function | [] -> () @@ -64,7 +66,33 @@ to_buffer t buf; Buffer.contents buf +let new_id = + let count = ref 0L in + (fun () -> count := Int64.add 1L !count; !count) +let string_of_call call = + let json = `Dict [ + "method", `String call.name; + "params", `List call.params; + "id", `Int (new_id ()); + ] in + to_string json + +let string_of_response id response = + let json = match response with + | Success v -> + `Dict [ + "result", v; + "error", `None; + "id", `Int id + ] + | Fault f -> + `Dict [ + "result", `None; + "error", f; + "id", `Int id + ] in + to_string json type error = | Unexpected_char of int * char * (* json type *) string @@ -94,13 +122,13 @@ | Expect_object_elem_colon | Expect_comma_or_end | Expect_object_key - | Done of Rpc.Val.t + | Done of Val.t type int_value = - | IObject of (string * Rpc.Val.t) list - | IObject_needs_key of (string * Rpc.Val.t) list - | IObject_needs_value of (string * Rpc.Val.t) list * string - | IArray of Rpc.Val.t list + | IObject of (string * Val.t) list + | IObject_needs_key of (string * Val.t) list + | IObject_needs_value of (string * Val.t) list * string + | IArray of Val.t list type parse_state = { mutable cursor: cursor; @@ -404,7 +432,7 @@ | Done _ -> raise_internal_error s "parse called when parse_state is 'Done'" type parse_result = - | Json_value of Rpc.Val.t * (* number of consumed bytes *) int + | Json_value of Val.t * (* number of consumed bytes *) int | Json_parse_incomplete of parse_state let parse_substring state str ofs len = @@ -454,3 +482,40 @@ end let of_string = Parser.of_string + +exception Malformed_method_request of string +exception Malformed_method_response of string + +let get name dict = + if List.mem_assoc name dict then + List.assoc name dict + else begin + Printf.eprintf "%s was not found in the dictionnary\n" name; + let str = List.map (fun (n,_) -> Printf.sprintf "%s=..." n) dict in + let str = Printf.sprintf "{%s}" (String.concat "," str) in + raise (Malformed_method_request str) + end + +let call_of_string str = + match of_string str with + | `Dict d -> + let name = match get "method" d with `String s -> s | _ -> raise (Malformed_method_request str) in + let params = match get "params" d with `List l -> l | _ -> raise (Malformed_method_request str) in + let id = match get "id" d with `Int i -> i | _ -> raise (Malformed_method_request str) in + id, { name = name; params = params } + | _ -> raise (Malformed_method_request str) + +let response_of_string str = + match of_string str with + | `Dict d -> + let result = get "result" d in + let error = get "error" d in + let id = match get "id" d with `Int i -> i | _ -> raise (Malformed_method_response str) in + begin match result, error with + | `None, `None -> raise (Malformed_method_response str) + | `None, v -> id, Fault v + | v, `None -> id, Success v + | _ -> raise (Malformed_method_response str) + end + | _ -> raise (Malformed_method_response str) + diff -r d85f31ed63ae rpc-light/jsonrpc.mli --- a/rpc-light/jsonrpc.mli Fri Dec 11 16:51:24 2009 +0000 +++ b/rpc-light/jsonrpc.mli Fri Dec 11 17:42:43 2009 +0000 @@ -14,3 +14,12 @@ val to_string : Rpc.Val.t -> string val of_string : string -> Rpc.Val.t + +val string_of_call: Rpc.call -> string +val call_of_string: string -> int64 * Rpc.call + +val string_of_response: int64 -> Rpc.Val.t Rpc.response -> string +val response_of_string: string -> int64 * Rpc.Val.t Rpc.response + + + diff -r d85f31ed63ae rpc-light/rpc.ml --- a/rpc-light/rpc.ml Fri Dec 11 16:51:24 2009 +0000 +++ b/rpc-light/rpc.ml Fri Dec 11 17:42:43 2009 +0000 @@ -49,6 +49,6 @@ params: Val.t list } -type response = +type 'a response = | Success of Val.t - | Fault of int64 * string + | Fault of 'a diff -r d85f31ed63ae rpc-light/xmlrpc.ml --- a/rpc-light/xmlrpc.ml Fri Dec 11 16:51:24 2009 +0000 +++ b/rpc-light/xmlrpc.ml Fri Dec 11 17:42:43 2009 +0000 @@ -264,14 +264,14 @@ List.rev !r end -let of_string ?callback str : Rpc.Val.t = +let of_string ?callback str = let input = Xmlm.make_input (`String (0, str)) in begin match Xmlm.peek input with | `Dtd _ -> ignore (Xmlm.input input) | _ -> () end; Parser.of_xml ?callback [] input -let call_of_string ?callback str : Rpc.call = +let call_of_string ?callback str = let input = Xmlm.make_input (`String (0, str)) in begin match Xmlm.peek input with | `Dtd _ -> ignore (Xmlm.input input) @@ -288,7 +288,7 @@ ) input; { Rpc.name = !name; Rpc.params = !params } -let response_of_string ?callback str : Rpc.response = +let response_of_string ?callback str = let input = Xmlm.make_input (`String (0, str)) in begin match Xmlm.peek input with | `Dtd _ -> ignore (Xmlm.input input) diff -r d85f31ed63ae rpc-light/xmlrpc.mli --- a/rpc-light/xmlrpc.mli Fri Dec 11 16:51:24 2009 +0000 +++ b/rpc-light/xmlrpc.mli Fri Dec 11 17:42:43 2009 +0000 @@ -18,5 +18,5 @@ 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 +val string_of_response: (int64 * string) Rpc.response -> string +val response_of_string: ?callback:Rpc.callback -> string -> (int64 * string) Rpc.response