Permalink
Browse files

comet client impl, doesn't quite work

  • Loading branch information...
1 parent 694f51d commit a92199322bd4c991a952756403d105dbdd22945f Jake Donham committed Jul 25, 2010
View
116 src/generator/gen_js_comet_clnt.ml
@@ -0,0 +1,116 @@
+(*
+ * This file is part of orpc, OCaml signature to ONC RPC generator
+ * Copyright (C) 2008-9 Skydeck, Inc
+ * Copyright (C) 2010 Jacob Donham
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+ * 02111-1307, USA
+ *)
+
+open Camlp4.PreCast
+open Ast
+open Types
+open Util
+
+module G = Gen_common
+
+let _loc = Camlp4.PreCast.Loc.ghost
+
+let gen_mli name (typedefs, excs, funcs, kinds) =
+
+ let modules =
+ List.map
+ (fun kind ->
+ let mt = G.string_of_kind kind in
+ <:sig_item<
+ module $uid:mt$ : functor (A : $uid:name$.$uid:mt$) ->
+ sig
+ val bind : Orpc_js_client.t -> unit
+ end
+ >>)
+ kinds in
+
+ <:sig_item< $list:modules$ >>
+
+let gen_ml name (typedefs, excs, funcs, kinds) =
+
+ let has_excs = excs <> [] in
+
+ let modules =
+ List.map
+ (fun kind ->
+ let mt = G.string_of_kind kind in
+ let func (_, id, args, res) =
+ match kind with
+ | Ik_abstract -> assert false
+
+ | Sync ->
+ let body =
+ let (ps, _) = G.vars args in
+ <:expr<
+ let ( $tup:paCom_of_list ps$ ) = Obj.obj x0 in
+ $G.args_apps <:expr< A.$lid:id$ >> args$
+ >> in
+ <:expr<
+ ($`str:id$,
+ fun x0 pass_reply ->
+ let r =
+ try
+ let r =
+ Obj.repr
+ $if has_excs
+ then <:expr< Orpc.pack_orpc_result (fun () -> $body$) >>
+ else body$
+ in (fun () -> r)
+ with e -> (fun () -> raise e) in
+ pass_reply r)
+ >>
+
+ | Lwt ->
+ let (ps, _) = G.vars args in
+ <:expr<
+ ($`str:id$,
+ fun x0 pass_reply ->
+ Lwt.ignore_result
+ (Lwt.try_bind
+ (fun () ->
+ let ( $tup:paCom_of_list ps$ ) = Obj.obj x0 in
+ $G.args_apps <:expr< A.$lid:id$ >> args$)
+ (fun v ->
+ let r =
+ Obj.repr $if has_excs
+ then <:expr< Orpc.Orpc_success v >>
+ else <:expr< v >>$ in
+ pass_reply (fun () -> r);
+ Lwt.return ())
+ (fun e ->
+ pass_reply
+ $if has_excs
+ then
+ (* XXX check for declared exception types *)
+ <:expr< let r = Obj.repr (Orpc.Orpc_failure e) in (fun () -> r) >>
+ else <:expr< fun () -> raise e >>$;
+ Lwt.return ())))
+ >> in
+
+ <:str_item<
+ module $uid:mt$(A : $uid:name$.$uid:mt$) =
+ struct
+ let bind t = Orpc_js_client.bind t $G.conses (List.map func funcs)$
+ end
+ >>)
+ kinds in
+
+ <:str_item< $list:modules$ >>
View
1 src/generator/main.ml
@@ -52,6 +52,7 @@ let do_file fn =
then [
"js_aux", Gen_js_aux.gen_mli, Gen_js_aux.gen_ml;
"js_clnt", Gen_js_clnt.gen_mli, Gen_js_clnt.gen_ml;
+ "js_comet_clnt", Gen_js_comet_clnt.gen_mli, Gen_js_comet_clnt.gen_ml;
"js_srv", Gen_js_srv.gen_mli, Gen_js_srv.gen_ml;
"trace", Gen_trace.gen_mli, Gen_trace.gen_ml;
] else [
View
2 src/orpc-js-client/_tags
@@ -1 +1 @@
-<orpc_js_client.ml> : pkg_ocamljs,pkg_javascript
+<orpc_js_client.ml> : pkg_ocamljs,pkg_javascript,pkg_dom
View
99 src/orpc-js-client/orpc_js_client.ml
@@ -19,6 +19,13 @@
* 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
@@ -40,38 +47,19 @@ let serialize o =
let unserialize = Javascript.eval
-(* this is in dom package but don't want dependency *)
-class type xMLHttpRequest =
-object
- method _set_onreadystatechange : (unit -> unit) -> unit
- method _get_readyState : int
- (* method _get_responseXML : Dom.document ? *)
- method _get_responseText : string
- method _get_status : int
- method _get_statusText : string
- method abort : unit
- method getAllResponseHeaders : string
- method getResponseHeader : string -> string
- method open__ : string -> string -> bool -> unit
- method send : string -> unit
- method setRequestHeader : string -> string -> unit
-end
-
-external new_XMLHttpRequest : unit -> xMLHttpRequest = "$new" "XMLHttpRequest"
-
type t = {
url : string;
mutable txn_id : int;
- mutable session_id : string;
+ 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) Hashtbl.t option;
+ mutable procs : (string * (Obj.t -> ((unit -> Obj.t) -> unit) -> unit)) list option;
}
let create url = {
url = url;
txn_id = 0;
- session_id = "";
+ session_id = None;
pending_calls = Hashtbl.create 17;
reqs_in_flight = 0;
procs = None;
@@ -89,8 +77,8 @@ type msg = {
}
let rec send t msg =
- let msg = { m_session_id = Some t.session_id; msg = msg } in
- let xhr = new_XMLHttpRequest () in
+ let msg = { m_session_id = t.session_id; msg = msg } in
+ let xhr = Dom.new_XMLHttpRequest () in
xhr#_set_onreadystatechange begin fun () ->
match xhr#_get_readyState with
| 4 ->
@@ -99,53 +87,64 @@ let rec send t msg =
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 = xhr#_get_statusText in (fun () -> raise (Failure s)) in
- Hashtbl.iter (fun _ f -> f r) t.pending_calls;
+ 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
| _ -> ()
end;
- xhr#open__ "POST" t.url true;
+ 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
and recv t msg =
begin match msg.m_session_id with
- | None -> ()
- | Some s -> t.session_id <- s
+ | 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 -> ()
+ | Noop -> console#log "got Noop"
| Call (txn_id, proc, arg) ->
+ console#log (Printf.sprintf "got Call (%d, %s, _)" txn_id proc);
begin
- match t.procs with
- | None -> ()
- | Some procs ->
- try
- Hashtbl.find procs proc arg begin fun r ->
- try send t (Res (txn_id, r ()))
- with e -> send t (Fail (txn_id, Printexc.to_string e))
- end
- with Not_found -> ()
+ 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
- try
- Hashtbl.find t.pending_calls txn_id (fun () -> o);
- Hashtbl.remove t.pending_calls txn_id
- with Not_found -> ()
+ 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
- try
- Hashtbl.find t.pending_calls txn_id (fun () -> raise (Failure s));
- Hashtbl.remove t.pending_calls txn_id
- with Not_found -> ()
+ 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 poll t = send t Noop
+and poll t = ignore (Dom.window#setTimeout (fun () -> send t Noop) 0.)
let call t proc arg pass_reply =
let txn_id = t.txn_id in
@@ -154,7 +153,5 @@ let call t proc arg pass_reply =
send t (Call (txn_id, proc, arg))
let bind t procs =
- let h = Hashtbl.create (List.length procs * 2) in
- List.iter (fun (k, v) -> Hashtbl.replace h k v) procs;
- t.procs <- Some h;
+ t.procs <- Some procs;
poll t
View
2 tools/myocamlbuild.ml
@@ -244,6 +244,7 @@ dispatch begin function
~prods:[
"%_js_aux.ml"; "%_js_aux.mli";
"%_js_clnt.ml"; "%_js_clnt.mli";
+ "%_js_comet_clnt.ml"; "%_js_comet_clnt.mli";
"%_js_srv.ml"; "%_js_srv.mli";
"%_trace.ml"; "%_trace.mli"
]
@@ -257,6 +258,7 @@ dispatch begin function
~prods:[
"%_js_aux.ml"; "%_js_aux.mli";
"%_js_clnt.ml"; "%_js_clnt.mli";
+ "%_js_comet_clnt.ml"; "%_js_comet_clnt.mli";
"%_js_srv.ml"; "%_js_srv.mli";
"%_trace.ml"; "%_trace.mli"
]

0 comments on commit a921993

Please sign in to comment.