Permalink
Browse files

Add Jon Ludlam's XmlHttpRequest javascript RPC function

From github.com/jonludlam/xen-api-client/blob/master/post.ml
  • Loading branch information...
1 parent d69fb96 commit bb2adaa1ef299b76cf66c87664a08d1d7629d19f David Scott committed Sep 29, 2012
Showing with 70 additions and 3 deletions.
  1. +6 −0 lib/META
  2. +11 −3 lib/Makefile
  3. +38 −0 lib/rpc_client_js.ml
  4. +15 −0 lib/rpc_client_js.mli
View
@@ -42,3 +42,9 @@ package "unix" (
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,38 @@
+open Lwt
+open Js
+
+let do_rpc url contents =
+ let method_ = "POST" in
+ let content_type = "text/xml" 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
+ {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 : string -> string -> XmlHttpRequest.http_frame Lwt.t

0 comments on commit bb2adaa

Please sign in to comment.