Merge pull request mirage#10 from djs55/unix-subpackage

Make more mirage and javascript friendly

lib/META

@@ -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"
+)

lib/Makefile

@@ -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 $@ $<
 

lib/rpc_client_js.ml

@@ -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

lib/rpc_client_js.mli

@@ -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