# HG changeset patch # User Thomas Gazagnaire [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 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 ""; + add ""; + add (check call.Rpc.name); + add ""; + List.iter (fun p -> + add ""; + add (to_string p); + add "" + ) call.Rpc.params; + add ""; + 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 ""; + add (to_string v); + add ""; + | Rpc.Fault (i,s) -> + add "faultCode"; + add (Int64.to_string i); + add "faultString"; + add s; + add ""; + 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