Permalink
Browse files

Merge pull request #10 from djs55/unix-subpackage

Make more mirage and javascript friendly
  • Loading branch information...
2 parents 4185770 + 2adaa55 commit 0a4d1de91156b5899a134bb473a6f0ffcfa7cc87 @samoht committed Sep 30, 2012
Showing with 80 additions and 3 deletions.
  1. +13 −0 lib/META
  2. +11 −3 lib/Makefile
  3. +41 −0 lib/rpc_client_js.ml
  4. +15 −0 lib/rpc_client_js.mli
View
@@ -35,3 +35,16 @@ package "json" (
archive(byte) = "jsonrpc.cmo"
archive(native) = "jsonrpc.cmx"
)
+
+package "unix" (
+ description = "Unix socket connection handling"
+ requires = "rpc.core"
+ archive(byte) = "rpc_client.cmo"
+ archive(native) = "rpc_client.cmx"
+)
+
+package "js" (
+ description = "Javascript/browser connection handling"
+ requires = "rpc.core"
+ archive(byte) = "rpc_client_js.cmo"
+)
View
@@ -1,16 +1,21 @@
OCAMLC = ocamlfind ocamlc
OCAMLOPT = ocamlfind ocamlopt
OCAMLFLAGS = -annot -g
-PACKS = xmlm
+PACKS = xmlm,lwt,js_of_ocaml,js_of_ocaml.syntax
+
+ICAMLP4 = -I $(shell ocamlfind query camlp4) \
+ -I $(shell ocamlfind query type_conv) \
+ -I $(shell ocamlfind query js_of_ocaml) \
+ -I $(shell ocamlfind query lwt)
-ICAMLP4 = -I $(shell ocamlfind query camlp4) -I $(shell ocamlfind query type_conv)
DOCDIR = /myrepos/xen-api-libs.hg/doc
TARGETS = \
rpc.cmi rpc.cmo rpc.o rpc.cmx \
pa_rpc.cma idl.cma \
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.cmi rpc_client.cmo rpc_client.o rpc_client.cmx \
+ rpc_client_js.cmi rpc_client_js.cmo
.PHONY: all clean
all: $(TARGETS)
@@ -33,6 +38,9 @@ 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
+ $(OCAMLC) $(OCAMLFLAGS) -package $(PACKS) -syntax camlp4o $(ICAMLP4) -c $@ $<
+
%.o %.cmx: %.ml
$(OCAMLOPT) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $<
View
@@ -0,0 +1,41 @@
+open Lwt
+open Js
+
+let do_rpc ~url call =
+ let method_ = "POST" in
+ let content_type = "text/xml" in
+ let contents = Xmlrpc.string_of_call 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;
+ }
+*)
+ | _ -> ()));
+
+ req##send (Js.some (Js.string contents));
+
+ Lwt.on_cancel res (fun () -> req##abort ()) ;
+ res
View
@@ -0,0 +1,15 @@
+(*
+ * Copyright (C) 2012 Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * 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 Lesser General Public License for more details.
+ *)
+
+val do_rpc : url:string -> Rpc.call -> Rpc.response Lwt.t

0 comments on commit 0a4d1de

Please sign in to comment.