Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

client transport may be xhr / xhr long poll

  • Loading branch information...
commit c298c5db9d903319175df514c4902cff573e667b 1 parent 7faa186
Jake Donham authored
View
123 src/orpc-js-client/orpc_js_client.ml
@@ -48,9 +48,11 @@ type msg =
type msgs = {
m_session_id : string option;
msgs : msg array;
+ sync : bool;
}
type t = {
+ transport : [ `Xhr | `Xhr_long_poll ];
url : string;
mutable txn_id : int;
mutable session_id : string option;
@@ -60,7 +62,8 @@ type t = {
mutable req_in_flight : bool;
}
-let create url = {
+let create ?(transport=`Xhr) url = {
+ transport = transport;
url = url;
txn_id = 0;
session_id = None;
@@ -73,7 +76,7 @@ let create url = {
let rec req t =
if not t.req_in_flight && t.queued_msgs <> []
then
- let msgs = { m_session_id = t.session_id; msgs = Array.of_list (List.rev t.queued_msgs); } in
+ let msgs = { m_session_id = t.session_id; msgs = Array.of_list (List.rev t.queued_msgs); sync = t.transport = `Xhr; } in
t.queued_msgs <- [];
let xhr = Dom.new_XMLHttpRequest () in
xhr#_set_onreadystatechange begin fun () ->
@@ -81,8 +84,7 @@ let rec req t =
| 4 ->
xhr#_set_onreadystatechange ignore;
t.req_in_flight <- false;
- recv t xhr;
- req t
+ ignore (Dom.window#setTimeout (fun () -> recv t xhr; req t) 0.)
| _ -> ()
end;
xhr#open_ "POST" t.url true;
@@ -96,8 +98,7 @@ and poll ?on_connect t =
match xhr#_get_readyState with
| 4 ->
xhr#_set_onreadystatechange ignore;
- recv ?on_connect t xhr;
- poll t
+ ignore (Dom.window#setTimeout (fun () -> recv ?on_connect t xhr; poll t) 0.)
| _ -> ()
end;
let url = t.url ^ "?nonce=" ^ string_of_float (Javascript.new_Date ())#getTime in
@@ -117,7 +118,7 @@ and recv ?on_connect t xhr =
then begin
(* don't know the txn_ids, so fail all *)
let r = let s = string_of_int xhr#_get_status ^ xhr#_get_statusText in (fun () -> raise (Failure s)) in
- Hashtbl.iter (fun _ f -> try f r with e -> ()) t.pending_calls;
+ Hashtbl.iter (fun _ f -> try f r with _ -> ()) t.pending_calls;
Hashtbl.clear t.pending_calls;
match on_connect with
| None -> ()
@@ -125,56 +126,58 @@ and recv ?on_connect t xhr =
end
else
let msgs = Obj.obj (unserialize xhr#_get_responseText) in
+ handle_msgs ?on_connect t msgs
- begin match msgs.m_session_id with
- | None -> ()
- | Some _ as id ->
- match t.session_id with
- | Some _ -> t.session_id <- id
- | None ->
- t.session_id <- id;
- match on_connect with
- | None -> ()
- | Some f -> f (fun () -> ())
- end;
-
- Array.iter
- (function
- | Call (txn_id, proc, arg) ->
- begin
- let proc =
- match t.procs with
- | None -> None
- | Some procs -> try Some (List.assoc proc procs) with Not_found -> None in
- match proc with
- | None -> send t (Fail (txn_id, Printexc.to_string (Invalid_argument "bad proc")))
- | Some proc ->
- proc arg begin fun r ->
- let reply =
- try Res (txn_id, r ())
- with e -> Fail (txn_id, Printexc.to_string e) in
- send t reply
- end
- end
- | Res (txn_id, o) ->
- begin
- let call = try Some (Hashtbl.find t.pending_calls txn_id) with Not_found -> None in
- match call with
- | None -> ()
- | Some call ->
- Hashtbl.remove t.pending_calls txn_id;
- call (fun () -> o)
- end
- | Fail (txn_id, s) ->
- begin
- let call = try Some (Hashtbl.find t.pending_calls txn_id) with Not_found -> None in
- match call with
- | None -> ()
- | Some call ->
- Hashtbl.remove t.pending_calls txn_id;
- call (fun () -> raise (Failure s))
- end)
- msgs.msgs
+and handle_msgs ?on_connect t msgs =
+ begin match msgs.m_session_id with
+ | None -> ()
+ | Some _ as id ->
+ match t.session_id with
+ | Some _ -> t.session_id <- id
+ | None ->
+ t.session_id <- id;
+ match on_connect with
+ | None -> ()
+ | Some f -> f (fun () -> ())
+ end;
+
+ let handle_msg = function
+ | Call (txn_id, proc, arg) ->
+ begin
+ let proc =
+ match t.procs with
+ | None -> None
+ | Some procs -> try Some (List.assoc proc procs) with Not_found -> None in
+ match proc with
+ | None -> send t (Fail (txn_id, Printexc.to_string (Invalid_argument "bad proc")))
+ | Some proc ->
+ proc arg begin fun r ->
+ let reply =
+ try Res (txn_id, r ())
+ with e -> Fail (txn_id, Printexc.to_string e) in
+ send t reply
+ end
+ end
+ | Res (txn_id, o) ->
+ begin
+ let call = try Some (Hashtbl.find t.pending_calls txn_id) with Not_found -> None in
+ match call with
+ | None -> ()
+ | Some call ->
+ Hashtbl.remove t.pending_calls txn_id;
+ call (fun () -> o)
+ end
+ | Fail (txn_id, s) ->
+ begin
+ let call = try Some (Hashtbl.find t.pending_calls txn_id) with Not_found -> None in
+ match call with
+ | None -> ()
+ | Some call ->
+ Hashtbl.remove t.pending_calls txn_id;
+ call (fun () -> raise (Failure s))
+ end in
+
+ Array.iter handle_msg msgs.msgs
let call t proc arg pass_reply =
let txn_id = t.txn_id in
@@ -183,7 +186,11 @@ let call t proc arg pass_reply =
send t (Call (txn_id, proc, arg))
let bind t procs =
- t.procs <- Some procs
+ match t.transport with
+ | `Xhr -> raise (Failure "bind not supported for `Xhr transport");
+ | _ -> t.procs <- Some procs
let connect t on_connect =
- poll ~on_connect t
+ match t.transport with
+ | `Xhr -> raise (Failure "connect not supported for `Xhr transport");
+ | _ -> poll ~on_connect t
View
2  src/orpc-js-client/orpc_js_client.mli
@@ -21,7 +21,7 @@
type t
-val create : string -> t
+val create : ?transport:[`Xhr|`Xhr_long_poll] -> string -> t
val call : t -> string -> Obj.t -> ((unit -> Obj.t) -> unit) -> unit
View
16 src/orpc-js-server/orpc_js_server.ml
@@ -206,6 +206,7 @@ type msg =
type msgs = {
m_session_id : string option;
msgs : msg array;
+ sync : bool;
}
let to_msg = function
@@ -220,15 +221,16 @@ let of_msg = function
| Fail (txn_id, msg) -> Oblock (2, [| of_int txn_id; of_string msg |])
let to_msgs = function
- | Oblock (0, [| m_session_id; msgs |]) ->
+ | Oblock (0, [| m_session_id; msgs; sync |]) ->
{
m_session_id = to_option to_string m_session_id;
- msgs = to_array to_msg msgs
+ msgs = to_array to_msg msgs;
+ sync = to_bool sync;
}
| _ -> invalid "msg"
-let of_msgs { m_session_id = m_session_id; msgs = msgs } =
- Oblock (0, [| of_option of_string m_session_id; of_array of_msg msgs |])
+let of_msgs { m_session_id = m_session_id; msgs = msgs; sync = sync } =
+ Oblock (0, [| of_option of_string m_session_id; of_array of_msg msgs; of_bool sync; |])
let msgs_of_string s = to_msgs (unserialize s)
let string_of_msgs msgs = serialize (of_msgs msgs)
@@ -255,13 +257,13 @@ struct
try
let msgs = msgs_of_string body in
let reply =
- match msgs.msgs with
- | [| Call (txn_id, proc, arg) |] ->
+ match msgs.sync, msgs.msgs with
+ | true, [| Call (txn_id, proc, arg) |] ->
let proc =
try List.assoc proc procs
with Not_found -> raise (Invalid_argument ("bad proc " ^ proc)) in
M.bind (proc arg) (fun res -> M.return (Res (txn_id, res)))
| _ -> raise (Invalid_argument "unsupported msgs") in
- M.bind reply (fun reply -> M.return (string_of_msgs { m_session_id = msgs.m_session_id; msgs = [| reply |] }))
+ M.bind reply (fun reply -> M.return (string_of_msgs { m_session_id = msgs.m_session_id; msgs = [| reply |]; sync = true; }))
with e -> M.fail e
end
View
1  src/orpc-js-server/orpc_js_server.mli
@@ -63,6 +63,7 @@ type msg =
type msgs = {
m_session_id : string option;
msgs : msg array;
+ sync : bool;
}
val msgs_of_string : string -> msgs
Please sign in to comment.
Something went wrong with that request. Please try again.