Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add support for using the browser's JSON parser.

This is a lot quicker than the one in jsonrpc.ml
  • Loading branch information...
commit 9fb99c3cd3ecec4296fb9a5b734160a2f41f2b61 1 parent e85fb8b
@jonludlam jonludlam authored
View
2  lib/META
@@ -46,5 +46,5 @@ package "unix" (
package "js" (
description = "Javascript/browser connection handling"
requires = "rpclib.core"
- archive(byte) = "rpc_client_js.cmo"
+ archive(byte) = "rpc_client_js.cma"
)
View
11 lib/Makefile
@@ -15,7 +15,8 @@ TARGETS = \
xmlrpc.cmi xmlrpc.cmo xmlrpc.o xmlrpc.cmx \
jsonrpc.cmi jsonrpc.cmo jsonrpc.o jsonrpc.cmx \
rpc_client.cmi rpc_client.cmo rpc_client.o rpc_client.cmx \
- rpc_client_js.cmi rpc_client_js.cmo
+ rpc_client_js.cmi rpc_client_js.cmo rpc_client_js_helper.cmo \
+ rpc_client.cmo rpc_client_js.cma
.PHONY: all clean
all: $(TARGETS)
@@ -38,7 +39,13 @@ p4_rpc.cmo: p4_rpc.ml rpc.cmo
p4_idl.cmo: p4_idl.ml p4_rpc.cmo
$(OCAMLC) $(OCAMLFLAGS) -c -package camlp4,type_conv -pp "camlp4orf" $(ICAMLP4) $@ $<
-rpc_client_js.cmo: rpc_client_js.ml
+rpc_client_js.cma: rpc_client_js_helper.cmo rpc_client_js.cmo
+ $(OCAMLC) $(OCAMLFLAGS) -package $(PACKS) -syntax camlp4o $(ICAMLP4) -a -o $@ $^
+
+rpc_client_js_helper.cmo: rpc_client_js_helper.ml
+ $(OCAMLC) $(OCAMLFLAGS) -package $(PACKS) -syntax camlp4o $(ICAMLP4) -c $@ $<
+
+rpc_client_js.cmo: rpc_client_js.ml rpc_client_js_helper.cmo
$(OCAMLC) $(OCAMLFLAGS) -package $(PACKS) -syntax camlp4o $(ICAMLP4) -c $@ $<
%.o %.cmx: %.ml
View
29 lib/rpc_client_js.ml
@@ -1,41 +1,26 @@
open Lwt
open Js
-let do_rpc ~url call =
+let do_rpc enc dec content_type ~url call =
let method_ = "POST" in
- let content_type = "text/xml" in
- let contents = Xmlrpc.string_of_call call in
+ let contents = enc call in
let (res, w) = Lwt.task () in
let req = XmlHttpRequest.create () in
req##_open (Js.string method_, Js.string url, Js._true);
req##setRequestHeader (Js.string "Content-type", Js.string content_type);
-
-(* List.iter (fun (n, v) -> req##setRequestHeader (Js.string n, Js.string v)) headers;*)
-
req##onreadystatechange <- Js.wrap_callback
(fun _ ->
(match req##readyState with
| XmlHttpRequest.DONE ->
- Lwt.wakeup w (Xmlrpc.response_of_string (Js.to_string req##responseText))
-(*
- {XmlHttpRequest.url = url;
- code = req##status;
- content = Js.to_string req##responseText;
- content_xml =
- (fun () ->
- match Js.Opt.to_option (req##responseXML) with
- | None -> None
- | Some doc ->
- if (Js.some doc##documentElement) == Js.null
- then None
- else Some doc);
- headers = fun _ -> None;
- }
-*)
+ Lwt.wakeup w (dec (Js.to_string req##responseText))
| _ -> ()));
req##send (Js.some (Js.string contents));
Lwt.on_cancel res (fun () -> req##abort ()) ;
res
+
+let do_xml_rpc = do_rpc Xmlrpc.string_of_call Xmlrpc.response_of_string "text/xml"
+let do_json_rpc = do_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string "text/json"
+let do_json_rpc_opt = do_rpc Rpc_client_js_helper.string_of_call Rpc_client_js_helper.response_of_string "text/json"
View
4 lib/rpc_client_js.mli
@@ -12,4 +12,6 @@
* GNU Lesser General Public License for more details.
*)
-val do_rpc : url:string -> Rpc.call -> Rpc.response Lwt.t
+val do_json_rpc : url:string -> Rpc.call -> Rpc.response Lwt.t
+val do_json_rpc_opt : url:string -> Rpc.call -> Rpc.response Lwt.t
+val do_xml_rpc : url:string -> Rpc.call -> Rpc.response Lwt.t
View
108 lib/rpc_client_js_helper.ml
@@ -0,0 +1,108 @@
+(* This module uses the browser's native JSON parsing and converts
+ * the result back to a Rpc.t type *)
+
+(* This require quite a lot of trial-and-error to make work :-( *)
+
+let keys obj =
+ let arr = Js.Unsafe.meth_call (Js.Unsafe.variable "Object") "keys" [| Js.Unsafe.inject obj |] in
+ List.map (Js.to_string) (Array.to_list (Js.to_array arr))
+
+(* This is apparently the ECMAscript approved way of checking whether something is an array *)
+let is_array obj =
+ let str = Js.Unsafe.call (Js.Unsafe.variable "Object.prototype.toString") obj [||] in
+ Js.to_string str = "[object Array]"
+
+(* Magic to find out whether something is one of the Js_of_ocaml Javascript string types *)
+let mlString_constr = Js.Unsafe.variable "MlString"
+let is_string obj =
+ Js.instanceof obj mlString_constr
+
+(* Seems to work. I hope there's a better way of doing this! *)
+let nullobj = Json.unsafe_input (Js.string "null")
+let is_null obj = Json.output obj = Js.string "null"
+
+let rec rpc_of_json json =
+ let ty = Js.typeof json in
+ match (Js.to_string ty) with
+ | "object" ->
+ if is_array json then begin
+ let l = Array.to_list (Js.to_array json) in
+ Rpc.Enum (List.map rpc_of_json l)
+ end else if is_string json then begin
+ Rpc.String (Js.to_string (Js.Unsafe.coerce json))
+ end else if is_null json then begin
+ Rpc.Null
+ end else begin
+ let okeys = keys json in
+ Rpc.Dict (List.map (fun x -> (x, rpc_of_json (Js.Unsafe.get json (Js.string x)))) okeys)
+ end
+ | "boolean" ->
+ Rpc.Bool (Js.to_bool (Obj.magic json))
+ | "number" ->
+ (* Convert all numbers to strings - the generic Rpc-light layer can deal with this *)
+ let str = Js.Unsafe.meth_call json "toString" [| |] in
+ Rpc.String (Js.to_string str)
+ | _ ->
+ (* Datetime maybe? *)
+ Firebug.console##log (Js.string (Printf.sprintf "Ack! got %s" (Js.to_string ty)));
+ Rpc.Bool false
+
+let of_string s = rpc_of_json (Json.unsafe_input (Js.string s))
+
+(* Here be lots of magic. This is mostly untested *)
+let to_string rpc =
+ let rec inner = function
+ | Rpc.Dict kvs ->
+ let o = Json.unsafe_input (Js.string "{}") in
+ List.iter (fun (x,y) -> Js.Unsafe.set o (Js.string x) (inner y)) kvs;
+ o
+ | Rpc.Int x -> Obj.magic (Js.string (Int64.to_string x))
+ | Rpc.Int32 x -> Obj.magic x
+ | Rpc.Float x -> Obj.magic (Js.string (string_of_float x))
+ | Rpc.String x -> Obj.magic (Js.string x)
+ | Rpc.Bool x -> Obj.magic (if x then Js._true else Js._false)
+ | Rpc.DateTime x -> Obj.magic (Js.string x)
+ | Rpc.Enum l -> Obj.magic (Js.array (Array.of_list (List.map inner l)))
+ | Rpc.Null -> Obj.magic (Js.null)
+ in Json.output (inner rpc)
+
+let new_id =
+ let count = ref 0l in
+ (fun () -> count := Int32.add 1l !count; !count)
+
+let string_of_call call =
+ let json = Rpc.Dict [
+ "method", Rpc.String call.Rpc.name;
+ "params", Rpc.Enum call.Rpc.params;
+ "id", Rpc.Int32 (new_id ());
+ ] in
+ Js.to_string (to_string json)
+
+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 dictionary\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_response str)
+ end
+
+let response_of_string str =
+ match of_string str with
+ | Rpc.Dict d ->
+ let result = get "result" d in
+ let error = get "error" d in
+ let (_:int64) = try match get "id" d with Rpc.Int i -> i | Rpc.String s -> Int64.of_string s with _ ->
+ Firebug.console##log (Js.string (Printf.sprintf "Weirdness: %s" (Rpc.to_string (get "id" d))));
+ raise (Malformed_method_response "id") in
+ begin match result, error with
+ | v, Rpc.Null -> Rpc.success v
+ | Rpc.Null, v -> Rpc.failure v
+ | x,y -> raise (Malformed_method_response (Printf.sprintf "<result=%s><error=%s>" (Rpc.to_string x) (Rpc.to_string y)))
+ end
+ | rpc ->
+ Firebug.console##log (Js.string (Rpc.to_string rpc));
+ failwith "Bah"
Please sign in to comment.
Something went wrong with that request. Please try again.