Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

support lwt/async servers in orpc-js, remove dep on nethttpd

  • Loading branch information...
commit c08913345b3bf19d4f31ced96abcc9b91283a866 1 parent 077a6a7
Jake Donham authored
View
135 src/generator/gen_js_srv.ml
@@ -30,38 +30,27 @@ let _loc = Camlp4.PreCast.Loc.ghost
let gen_mli name (typedefs, excs, funcs, mode) =
- let qual_id = G.qual_id_aux name mode in
-
let modules =
match mode with
- | Simple -> []
+ | Simple -> failwith "simple mode not supported for js_srv"
| Modules kinds ->
List.map
(fun kind ->
- if kind <> Sync then <:sig_item< >>
- else
- <:sig_item<
- module Sync : functor (A : $uid:name$.Sync) ->
- sig
- val handler : string -> string
- end
- >>)
+ let mt, monad =
+ match kind with
+ | Ik_abstract -> assert false
+ | Sync -> "Sync", <:ident< Orpc_js_server.Sync >>
+ | Async -> "Async", <:ident< Orpc_js_server.Async >>
+ | Lwt -> "Lwt", <:ident< Lwt >> in
+ <:sig_item<
+ module $uid:mt$ : functor (A : $uid:name$.$uid:mt$) ->
+ sig
+ val handler : string -> string $id:monad$.t
+ end
+ >>)
kinds in
- <:sig_item<
- val handler :
- $List.fold_right
- (fun (_, id, args, res) t ->
- <:ctyp<
- $lid:"proc_" ^ id$ :
- $G.args_arrows qual_id args (G.gen_type qual_id res)$
- -> $t$
- >>)
- funcs
- <:ctyp< string -> string >>$ ;;
-
- $list:modules$
- >>
+ <:sig_item< $list:modules$ >>
@@ -85,58 +74,92 @@ let gen_ml name (typedefs, excs, funcs, mode) =
(let (ps, _) = G.vars args in
<:expr<
let ( $tup:paCom_of_list ps$ ) = $id:to_arg id$ x0 in
- $G.args_apps <:expr< $lid:"proc_" ^ id$ >> args$
+ $G.args_apps <:expr< A.$lid:id$ >> args$
>>)$)
>> in
+ let async_func (_, id, args, _) =
+ <:expr<
+ ($`str:id$,
+ fun x0 rf ->
+ $(fun body ->
+ if has_excs
+ then <:expr< pack_orpc_result_async (fun k -> $body$ k) >>
+ else <:expr< $body$ >>)
+ (let (ps, _) = G.vars args in
+ <:expr<
+ let ( $tup:paCom_of_list ps$ ) = $id:to_arg id$ x0 in
+ $G.args_apps <:expr< A.$lid:id$ >> args$
+ >>)$
+ (fun r -> let r = Obj.repr (r ()) in rf (fun () -> r)))
+ >> in
+
+ let lwt_func (_, id, args, _) =
+ <:expr<
+ ($`str:id$,
+ fun x0 ->
+ Lwt.try_bind
+ (fun () ->
+ $let (ps, _) = G.vars args in
+ <:expr<
+ let ( $tup:paCom_of_list ps$ ) = $id:to_arg id$ x0 in
+ $G.args_apps <:expr< A.$lid:id$ >> args$
+ >>$)
+ (fun v ->
+ Lwt.return
+ (Obj.repr
+ ($if has_excs
+ then <:expr< Orpc.Orpc_success v >>
+ else <:expr< v >>$)))
+ (fun e ->
+ $if has_excs
+ then <:expr< Lwt.return (Obj.repr (map_exns e)) >>
+ else <:expr< Lwt.fail e >>$))
+ >> in
+
let modules =
match mode with
- | Simple -> []
+ | Simple -> failwith "simple mode not supported for js_srv"
| Modules kinds ->
List.map
(fun kind ->
- if kind <> Sync then <:str_item< >>
- else
- <:str_item<
- module Sync (A : $uid:name$.Sync) =
- struct
- let handler =
- $List.fold_left
- (fun e (_, id, args, _) ->
- let body = <:expr< A.$lid:id$ >> in
- ExApp(_loc, e, ExLab (_loc, "proc_" ^ id, body)))
- <:expr< handler >>
- funcs$
- end
- >>)
+ let mt, monad, func =
+ match kind with
+ | Ik_abstract -> assert false
+ | Sync -> "Sync", <:ident< Orpc_js_server.Sync >>, sync_func
+ | Async -> "Async", <:ident< Orpc_js_server.Async >>, async_func
+ | Lwt -> "Lwt", <:ident< Lwt >>, lwt_func in
+ <:str_item<
+ module $uid:mt$ (A : $uid:name$.$uid:mt$) =
+ struct
+ module H = Orpc_js_server.Handler($id:monad$)
+ let handler = H.handler $G.conses (List.map func funcs)$
+ end
+ >>)
kinds in
let pack_orpc_result () =
let mc (_,id,ts) =
match ts with
| [] -> <:match_case< $id:qual_id id$ -> Orpc.Orpc_failure e >>
- | [_] -> <:match_case< $id:qual_id id$ _ -> Orpc.Orpc_failure e >>
- | _ ->
- <:match_case<
- $G.papps <:patt< $id:qual_id id$ >> (List.map (fun _ -> <:patt< _ >>) ts)$ -> Orpc.Orpc_failure e
- >> in
+ | _ -> <:match_case< $id:qual_id id$ _ -> Orpc.Orpc_failure e >> in
<:str_item<
+ let map_exns e =
+ match e with
+ | $list:List.map mc excs$
+ | _ -> raise e
+
let pack_orpc_result f =
try Orpc.Orpc_success (f ())
- with e ->
- match e with
- | $list:List.map mc excs$
- | _ -> raise e
+ with e -> map_exns e
+
+ let pack_orpc_result_async f k =
+ try f (fun r -> let r = try Orpc.Orpc_success (r ()) with e -> map_exns e in k (fun () -> r))
+ with e -> let r = map_exns e in k (fun () -> r)
>> in
<:str_item<
$if has_excs then pack_orpc_result () else <:str_item< >>$ ;;
- let handler =
- $List.fold_right
- (fun (_, id, _, _) e -> <:expr< fun ~ $lid:"proc_" ^ id$ -> $e$ >>)
- funcs
- <:expr< Orpc_js_server.handler $G.conses (List.map sync_func funcs)$ >>$ ;;
-
$list:modules$
>>
View
2  src/orpc-js-server/META
@@ -1,6 +1,6 @@
name="Orpc-js-server"
version="0.3"
description="Orpc-js support for server"
-requires = "nethttpd,ulex,jslib,orpc"
+requires = "ulex,jslib,orpc"
archive(byte) = "orpc-js-server.cma"
archive(native) = "orpc-js-server.cmxa"
View
63 src/orpc-js-server/orpc_js_server.ml
@@ -192,33 +192,36 @@ let unserialize s =
| Teoi -> o
| _ -> invalid "serialized heap object"
-let handler procs body =
- let (proc_name, arg) =
- match unserialize body with
- | Oblock (0, [| Ostring proc_name; arg |]) -> proc_name, arg
- | _ -> raise (Invalid_argument "bad request") in
- let proc =
- try List.assoc proc_name procs
- with Not_found -> raise (Invalid_argument ("bad request " ^ proc_name)) in
- serialize (proc arg)
-
-let service handler =
- let process (cgi : Netcgi_types.cgi_activation) =
- let res =
- try handler (cgi#argument "BODY")#value
- with Not_found -> raise (Invalid_argument "bad_request") in
- (* XXX handle gzip *)
- cgi#set_header
- ~content_type:"text/plain; charset=utf-8"
- ~cache:`No_cache
- ();
- cgi#output#output_string res;
- cgi#output#commit_work () in
-
- {
- Nethttpd_services.dyn_handler = (fun _ -> process);
- dyn_activation = Nethttpd_services.std_activation `Std_activation_unbuffered;
- dyn_uri = None;
- dyn_translator = (fun _ -> "");
- dyn_accept_all_conditionals = false;
- }
+module type Monad =
+sig
+ type 'a t
+ val return : 'a -> 'a t
+ val bind : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Sync =
+struct
+ type 'a t = 'a
+ let return x = x
+ let bind x f = f x
+end
+
+module Async =
+struct
+ type 'a t = ((unit -> 'a) -> unit) -> unit
+ let return x = fun f -> f (fun () -> x)
+ let bind x f = fun rf -> x (fun r -> f (r ()) rf)
+end
+
+module Handler (M : Monad) =
+struct
+ let handler procs body =
+ let (proc_name, arg) =
+ match unserialize body with
+ | Oblock (0, [| Ostring proc_name; arg |]) -> proc_name, arg
+ | _ -> raise (Invalid_argument "bad request") in
+ let proc =
+ try List.assoc proc_name procs
+ with Not_found -> raise (Invalid_argument ("bad request " ^ proc_name)) in
+ M.bind (proc arg) (fun s -> M.return (serialize s))
+end
View
17 src/orpc-js-server/orpc_js_server.mli
@@ -37,7 +37,18 @@ val to_string : obj -> string
val to_list : (obj -> 'a) -> obj -> 'a list
val to_option : (obj -> 'a) -> obj -> 'a option
-val handler : (string * (obj -> Obj.t)) list -> (string -> string)
-val service : (string -> string) -> Netcgi_types.cgi_activation Nethttpd_services.dynamic_service
-
val set_debug : (string -> unit) -> unit
+
+module type Monad =
+sig
+ type 'a t
+ val return : 'a -> 'a t
+ val bind : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Sync : Monad with type 'a t = 'a
+module Async : Monad with type 'a t = ((unit -> 'a) -> unit) -> unit
+
+module Handler (M : Monad) : sig
+ val handler : (string * (obj -> Obj.t M.t)) list -> (string -> string M.t)
+end
Please sign in to comment.
Something went wrong with that request. Please try again.