Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

working comet client

  • Loading branch information...
commit 858e288f246523cb4fe7aa8bf7972e5011ffd337 1 parent 050c2c8
Jake Donham authored
View
200 src/orpc-js-client/orpc_js_client.ml
@@ -19,13 +19,6 @@
* MA 02111-1307, USA
*)
-class type console =
-object
- method log : string -> unit
-end
-
-let console : console = Ocamljs.var "console"
-
let serialize o =
let a = Javascript.new_Array () in
let push o = ignore (a#push o) in
@@ -47,104 +40,141 @@ let serialize o =
let unserialize = Javascript.eval
+type msg =
+ | Call of int * string * Obj.t
+ | Res of int * Obj.t
+ | Fail of int * string
+
+type msgs = {
+ m_session_id : string option;
+ msgs : msg array;
+}
+
type t = {
url : string;
mutable txn_id : int;
mutable session_id : string option;
- pending_calls : (int, (unit -> Obj.t) -> unit) Hashtbl.t;
- mutable reqs_in_flight : int;
mutable procs : (string * (Obj.t -> ((unit -> Obj.t) -> unit) -> unit)) list option;
+ pending_calls : (int, (unit -> Obj.t) -> unit) Hashtbl.t;
+ mutable queued_msgs : msg list;
+ mutable req_in_flight : bool;
}
let create url = {
url = url;
txn_id = 0;
session_id = None;
- pending_calls = Hashtbl.create 17;
- reqs_in_flight = 0;
procs = None;
+ pending_calls = Hashtbl.create 17;
+ queued_msgs = [];
+ req_in_flight = false;
}
-type msg_t =
- | Noop
- | Call of int * string * Obj.t
- | Res of int * Obj.t
- | Fail of int * string
-
-type msg = {
- m_session_id : string option;
- msg : msg_t;
-}
+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
+ t.queued_msgs <- [];
+ let xhr = Dom.new_XMLHttpRequest () in
+ xhr#_set_onreadystatechange begin fun () ->
+ match xhr#_get_readyState with
+ | 4 ->
+ xhr#_set_onreadystatechange ignore;
+ t.req_in_flight <- false;
+ recv t xhr;
+ req t
+ | _ -> ()
+ end;
+ xhr#open_ "POST" t.url true;
+ xhr#setRequestHeader "Content-Type" "text/plain; charset=utf-8";
+ xhr#send (serialize (Obj.repr msgs));
+ t.req_in_flight <- true
-let rec send t msg =
- let msg = { m_session_id = t.session_id; msg = msg } in
+and poll ?on_connect t =
let xhr = Dom.new_XMLHttpRequest () in
xhr#_set_onreadystatechange begin fun () ->
match xhr#_get_readyState with
| 4 ->
- t.reqs_in_flight <- t.reqs_in_flight - 1;
- if xhr#_get_status = 200
- then recv t (Obj.obj (unserialize xhr#_get_responseText))
- else begin
- (* if we can't read the msg we don't know the txn_id, 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 -> console#log (Obj.magic e)) t.pending_calls;
- Hashtbl.clear t.pending_calls
- end;
- if t.procs <> None && t.reqs_in_flight = 0 then poll t
+ xhr#_set_onreadystatechange ignore;
+ recv ?on_connect t xhr;
+ poll t
| _ -> ()
end;
- xhr#open_ "POST" t.url true;
- xhr#setRequestHeader "Content-Type" "text/plain; charset=utf-8";
- xhr#send (serialize (Obj.repr msg));
- t.reqs_in_flight <- t.reqs_in_flight + 1
+ let url = t.url ^ "?nonce=" ^ string_of_float (Javascript.new_Date ())#getTime in
+ let url =
+ match t.session_id with
+ | None -> url
+ | Some session_id -> url ^ "&session_id=" ^ session_id in
+ xhr#open_ "GET" url true;
+ xhr#send (Ocamljs.null ());
-and recv t msg =
- begin match msg.m_session_id with
- | None -> console#log "got no session id"
- | Some id -> console#log ("got session id " ^ id); t.session_id <- msg.m_session_id
- end;
- match msg.msg with
- | Noop -> console#log "got Noop"
- | Call (txn_id, proc, arg) ->
- console#log (Printf.sprintf "got Call (%d, %s, _)" txn_id proc);
- 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) ->
- console#log (Printf.sprintf "got Res (%d, _)" txn_id);
- 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) ->
- console#log (Printf.sprintf "got Fail (%d, _)" txn_id);
- 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
+and send t msg =
+ t.queued_msgs <- msg :: t.queued_msgs;
+ req t
-and poll t = ignore (Dom.window#setTimeout (fun () -> send t Noop) 0.)
+and recv ?on_connect t xhr =
+ if xhr#_get_status <> 200
+ 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.clear t.pending_calls;
+ match on_connect with
+ | None -> ()
+ | Some f -> f r
+ end
+ else
+ let msgs = Obj.obj (unserialize xhr#_get_responseText) in
+
+ 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
let call t proc arg pass_reply =
let txn_id = t.txn_id in
@@ -153,5 +183,7 @@ let call t proc arg pass_reply =
send t (Call (txn_id, proc, arg))
let bind t procs =
- t.procs <- Some procs;
- poll t
+ t.procs <- Some procs
+
+let connect t on_connect =
+ poll ~on_connect t
View
2  src/orpc-js-client/orpc_js_client.mli
@@ -26,3 +26,5 @@ val create : string -> t
val call : t -> string -> Obj.t -> ((unit -> Obj.t) -> unit) -> unit
val bind : t -> (string * (Obj.t -> ((unit -> Obj.t) -> unit) -> unit)) list -> unit
+
+val connect : t -> ((unit -> unit) -> unit) -> unit
View
66 src/orpc-js-server/orpc_js_server.ml
@@ -187,7 +187,7 @@ let unserialize s =
| Tblock_end ->
begin
match block with
- | Onumber tag :: ((_::_) as fields) -> Oblock (int_of_float tag, Array.of_list (List.rev fields))
+ | Onumber tag :: fields -> Oblock (int_of_float tag, Array.of_list (List.rev fields))
| _ -> invalid "block"
end
| _ -> Ulexing.rollback lb; loop2 (loop () :: block) in
@@ -198,40 +198,40 @@ let unserialize s =
| Teoi -> o
| _ -> invalid "serialized heap object"
-type msg_t =
- | Noop
+type msg =
| Call of int * string * obj
| Res of int * obj
| Fail of int * string
-type msg = {
+type msgs = {
m_session_id : string option;
- msg : msg_t;
+ msgs : msg array;
}
-let msg_of_string s =
- match unserialize s with
- | Oblock (0, [| m_session_id; msg |]) ->
- let m_session_id = to_option to_string m_session_id in
- let msg =
- match msg with
- | Onumber 0. -> Noop
- | Oblock (0, [| txn_id; proc; arg |]) -> Call (to_int txn_id, to_string proc, arg)
- | Oblock (1, [| txn_id; res |]) -> Res (to_int txn_id, res)
- | Oblock (2, [| txn_id; msg |]) -> Fail (to_int txn_id, to_string msg)
- | _ -> invalid "msg_t" in
- { m_session_id = m_session_id; msg = msg }
- | _ -> invalid "msg"
-
-let string_of_msg { m_session_id = m_session_id; msg = msg } =
- let m_session_id = of_option of_string m_session_id in
- let msg =
- match msg with
- | Noop -> Onumber 0.
- | Call (txn_id, proc, arg) -> Oblock (0, [| of_int txn_id; of_string proc; arg |])
- | Res (txn_id, res) -> Oblock (1, [| of_int txn_id; res |])
- | Fail (txn_id, msg) -> Oblock (2, [| of_int txn_id; of_string msg |]) in
- serialize (Oblock (0, [| m_session_id; msg |]))
+let to_msg = function
+ | Oblock (0, [| txn_id; proc; arg |]) -> Call (to_int txn_id, to_string proc, arg)
+ | Oblock (1, [| txn_id; res |]) -> Res (to_int txn_id, res)
+ | Oblock (2, [| txn_id; msg |]) -> Fail (to_int txn_id, to_string msg)
+ | _ -> invalid "msg_t"
+
+let of_msg = function
+ | Call (txn_id, proc, arg) -> Oblock (0, [| of_int txn_id; of_string proc; arg |])
+ | Res (txn_id, res) -> Oblock (1, [| of_int txn_id; res |])
+ | Fail (txn_id, msg) -> Oblock (2, [| of_int txn_id; of_string msg |])
+
+let to_msgs = function
+ | Oblock (0, [| m_session_id; msgs |]) ->
+ {
+ m_session_id = to_option to_string m_session_id;
+ msgs = to_array to_msg msgs
+ }
+ | _ -> 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 msgs_of_string s = to_msgs (unserialize s)
+let string_of_msgs msgs = serialize (of_msgs msgs)
module type Monad =
sig
@@ -253,15 +253,15 @@ module Handler (M : Monad) =
struct
let handler procs body =
try
- let msg = msg_of_string body in
+ let msgs = msgs_of_string body in
let reply =
- match msg.msg with
- | Call (txn_id, proc, arg) ->
+ match msgs.msgs with
+ | [| 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)))
- | Noop | Res _ | Fail _ -> raise (Invalid_argument "unsupported message") in
- M.bind reply (fun reply -> M.return (string_of_msg { m_session_id = msg.m_session_id; msg = reply }))
+ | _ -> 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 |] }))
with e -> M.fail e
end
View
11 src/orpc-js-server/orpc_js_server.mli
@@ -55,19 +55,18 @@ val of_ref : ('a -> obj) -> 'a ref -> obj
val set_debug : (string -> unit) -> unit
-type msg_t =
- | Noop
+type msg =
| Call of int * string * obj
| Res of int * obj
| Fail of int * string
-type msg = {
+type msgs = {
m_session_id : string option;
- msg : msg_t;
+ msgs : msg array;
}
-val msg_of_string : string -> msg
-val string_of_msg : msg -> string
+val msgs_of_string : string -> msgs
+val string_of_msgs : msgs -> string
module type Monad =
sig
Please sign in to comment.
Something went wrong with that request. Please try again.