ocaml: Add XS bindings.

Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>

tools/ocaml/libs/eventchn/META.in

@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Eventchn interface extension"
+archive(byte) = "eventchn.cma"
+archive(native) = "eventchn.cmxa"

tools/ocaml/libs/eventchn/Makefile

@@ -0,0 +1,28 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OBJS = eventchn
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = eventchn.cma eventchn.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+eventchn_OBJS = $(OBJS)
+eventchn_C_OBJS = eventchn_stubs
+
+OCAML_LIBRARY = eventchn
+
+.PHONY: install
+install: $(LIBS) META
+	ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore eventchn META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+	ocamlfind remove eventchn
+
+include $(TOPLEVEL)/Makefile.rules
+

tools/ocaml/libs/eventchn/eventchn.ml

@@ -0,0 +1,27 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+exception Error of string
+
+external init: unit -> Unix.file_descr = "stub_eventchn_init"
+external notify: Unix.file_descr -> int -> unit = "stub_eventchn_notify"
+external bind_interdomain: Unix.file_descr -> int -> int -> int = "stub_eventchn_bind_interdomain"
+external bind_virq: Unix.file_descr -> int = "stub_eventchn_bind_virq"
+external unbind: Unix.file_descr -> int -> unit = "stub_eventchn_unbind"
+external read_port: Unix.file_descr -> int = "stub_eventchn_read_port"
+external write_port: Unix.file_descr -> int -> unit = "stub_eventchn_write_port"
+
+let _ = Callback.register_exception "eventchn.error" (Error "register_callback")

tools/ocaml/libs/eventchn/eventchn.mli

@@ -0,0 +1,26 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+exception Error of string
+external init : unit -> Unix.file_descr = "stub_eventchn_init"
+external notify : Unix.file_descr -> int -> unit = "stub_eventchn_notify"
+external bind_interdomain : Unix.file_descr -> int -> int -> int
+  = "stub_eventchn_bind_interdomain"
+external bind_virq : Unix.file_descr -> int = "stub_eventchn_bind_virq"
+external unbind : Unix.file_descr -> int -> unit = "stub_eventchn_unbind"
+external read_port : Unix.file_descr -> int = "stub_eventchn_read_port"
+external write_port : Unix.file_descr -> int -> unit
+  = "stub_eventchn_write_port"

tools/ocaml/libs/eventchn/eventchn_stubs.c

@@ -0,0 +1,173 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ */
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <errno.h>
+#include <stdint.h>
+
+#include <sys/ioctl.h>
+
+#define __XEN_TOOLS__
+
+#include <xen/sysctl.h>
+
+#if XEN_SYSCTL_INTERFACE_VERSION < 4
+#include <xen/linux/evtchn.h>
+#else
+#include <xen/xen.h>
+#include <xen/sys/evtchn.h>
+#endif
+
+#include <xenctrl.h>
+
+#define CAML_NAME_SPACE
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#define EVENTCHN_PATH "/dev/xen/eventchn"
+
+static int eventchn_major = 10;
+static int eventchn_minor = 61;
+
+static int do_ioctl(int handle, int cmd, void *arg)
+{
+	return ioctl(handle, cmd, arg);
+}
+
+static int do_read_port(int handle, evtchn_port_t *port)
+{
+	return (read(handle, port, sizeof(evtchn_port_t)) != sizeof(evtchn_port_t));
+}
+
+static int do_write_port(int handle, evtchn_port_t port)
+{
+	return (write(handle, &port, sizeof(evtchn_port_t)) != sizeof(evtchn_port_t));
+}
+
+int eventchn_do_open(void)
+{
+	int fd;
+
+	fd = open(EVENTCHN_PATH, O_RDWR);
+	if (fd == -1 && errno == ENOENT) {
+		mkdir("/dev/xen", 0640);
+		mknod(EVENTCHN_PATH, S_IFCHR | 0640, makedev(eventchn_major, eventchn_minor));
+		fd = open(EVENTCHN_PATH, O_RDWR);
+	}
+	return fd;
+}
+
+CAMLprim value stub_eventchn_init(value unit)
+{
+	CAMLparam1(unit);
+	int fd = eventchn_do_open();
+	if (fd == -1)
+		caml_failwith("open failed");
+	CAMLreturn(Val_int(fd));
+}
+
+CAMLprim value stub_eventchn_notify(value fd, value port)
+{
+	CAMLparam2(fd, port);
+	struct ioctl_evtchn_notify notify;
+	int rc;
+
+	notify.port = Int_val(port);
+	rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_NOTIFY, &notify);
+	if (rc == -1)
+		caml_failwith("ioctl notify failed");
+
+	CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_eventchn_bind_interdomain(value fd, value domid,
+                                              value remote_port)
+{
+	CAMLparam3(fd, domid, remote_port);
+	CAMLlocal1(port);
+	struct ioctl_evtchn_bind_interdomain bind;
+	int rc;
+
+	bind.remote_domain = Int_val(domid);
+	bind.remote_port = Int_val(remote_port);
+	rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_INTERDOMAIN, &bind);
+	if (rc == -1)
+		caml_failwith("ioctl bind_interdomain failed");
+	port = Val_int(rc);
+
+	CAMLreturn(port);
+}
+
+CAMLprim value stub_eventchn_bind_virq(value fd)
+{
+	CAMLparam1(fd);
+	CAMLlocal1(port);
+	struct ioctl_evtchn_bind_virq bind;
+	int rc;
+
+	bind.virq = VIRQ_DOM_EXC;
+	rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_VIRQ, &bind);
+	if (rc == -1)
+		caml_failwith("ioctl bind_virq failed");
+	port = Val_int(rc);
+
+	CAMLreturn(port);
+}
+
+CAMLprim value stub_eventchn_unbind(value fd, value port)
+{
+	CAMLparam2(fd, port);
+	struct ioctl_evtchn_unbind unbind;
+	int rc;
+
+	unbind.port = Int_val(port);
+	rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_UNBIND, &unbind);
+	if (rc == -1)
+		caml_failwith("ioctl unbind failed");
+
+	CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_eventchn_read_port(value fd)
+{
+	CAMLparam1(fd);
+	CAMLlocal1(result);
+	evtchn_port_t port;
+
+	if (do_read_port(Int_val(fd), &port))
+		caml_failwith("read port failed");
+	result = Val_int(port);
+
+	CAMLreturn(result);
+}
+
+CAMLprim value stub_eventchn_write_port(value fd, value _port)
+{
+	CAMLparam2(fd, _port);
+	evtchn_port_t port;
+
+	port = Int_val(_port);
+	if (do_write_port(Int_val(fd), port))
+		caml_failwith("write port failed");
+	CAMLreturn(Val_unit);
+}

tools/ocaml/libs/xb/META.in

@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "XenBus Interface"
+archive(byte) = "xb.cma"
+archive(native) = "xb.cmxa"

tools/ocaml/libs/xb/Makefile

@@ -0,0 +1,41 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+CFLAGS += -I../mmap
+OCAMLINCLUDE += -I ../mmap
+
+.NOTPARALLEL:
+# Ocaml is such a PITA!
+
+PREINTF = op.cmi partial.cmi packet.cmi
+PREOBJS = op partial packet xs_ring
+PRELIBS = $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJBS),$(obj).cmx)
+OBJS = op partial packet xs_ring xb
+INTF = op.cmi packet.cmi xb.cmi
+LIBS = xb.cma xb.cmxa
+
+ALL_OCAML_OBJS = $(OBJS) $(PREOJBS)
+
+all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+xb_OBJS = $(OBJS)
+xb_C_OBJS = xs_ring_stubs xb_stubs
+OCAML_LIBRARY = xb
+
+%.mli: %.ml
+	$(E) " MLI       $@"
+	$(Q)$(OCAMLC) -i $< $o
+
+.PHONY: install
+install: $(LIBS) META
+	ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xb META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+	ocamlfind remove xb
+
+include $(TOPLEVEL)/Makefile.rules

tools/ocaml/libs/xb/op.ml

@@ -0,0 +1,84 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+type operation = Debug | Directory | Read | Getperms |
+                 Watch | Unwatch | Transaction_start |
+                 Transaction_end | Introduce | Release |
+                 Getdomainpath | Write | Mkdir | Rm |
+                 Setperms | Watchevent | Error | Isintroduced |
+                 Resume | Set_target
+               | Restrict 
+
+(* There are two sets of XB operations: the one coming from open-source and *)
+(* the one coming from our private patch queue. These operations            *)
+(* in two differents arrays for make easier the forward compatibility       *)
+let operation_c_mapping =
+	[| Debug; Directory; Read; Getperms;
+           Watch; Unwatch; Transaction_start;
+           Transaction_end; Introduce; Release;
+           Getdomainpath; Write; Mkdir; Rm;
+           Setperms; Watchevent; Error; Isintroduced;
+           Resume; Set_target |]
+let size = Array.length operation_c_mapping
+
+(* [offset_pq] has to be the same as in <xen/io/xs_wire.h> *)
+let offset_pq = size
+let operation_c_mapping_pq =
+	[| Restrict |]
+let size_pq = Array.length operation_c_mapping_pq
+
+let array_search el a =
+	let len = Array.length a in
+	let rec search i =
+		if i > len then raise Not_found;
+		if a.(i) = el then i else search (i + 1) in
+	search 0
+
+let of_cval i =
+	if i >= 0 && i < size
+	then operation_c_mapping.(i)
+	else if i >= offset_pq && i < offset_pq + size_pq
+	then operation_c_mapping_pq.(i-offset_pq)
+	else raise Not_found
+
+let to_cval op =
+	try
+	array_search op operation_c_mapping
+	with _ -> offset_pq + array_search op operation_c_mapping_pq
+
+let to_string ty =
+	match ty with
+	| Debug			-> "DEBUG"
+	| Directory		-> "DIRECTORY"
+	| Read			-> "READ"
+	| Getperms		-> "GET_PERMS"
+	| Watch			-> "WATCH"
+	| Unwatch		-> "UNWATCH"
+	| Transaction_start	-> "TRANSACTION_START"
+	| Transaction_end	-> "TRANSACTION_END"
+	| Introduce		-> "INTRODUCE"
+	| Release		-> "RELEASE"
+	| Getdomainpath		-> "GET_DOMAIN_PATH"
+	| Write			-> "WRITE"
+	| Mkdir			-> "MKDIR"
+	| Rm			-> "RM"
+	| Setperms		-> "SET_PERMS"
+	| Watchevent		-> "WATCH_EVENT"
+	| Error			-> "ERROR"
+	| Isintroduced		-> "IS_INTRODUCED"
+	| Resume		-> "RESUME"
+	| Set_target		-> "SET_TARGET"
+	| Restrict		-> "RESTRICT"

tools/ocaml/libs/xb/packet.ml

@@ -0,0 +1,50 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+type t =
+{
+	tid: int;
+	rid: int;
+	ty: Op.operation;
+	data: string;
+}
+
+exception Error of string
+exception DataError of string
+
+external string_of_header: int -> int -> int -> int -> string = "stub_string_of_header"
+
+let create tid rid ty data = { tid = tid; rid = rid; ty = ty; data = data; }
+
+let of_partialpkt ppkt =
+	create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.contents ppkt.Partial.buf)
+
+let to_string pkt =
+	let header = string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (String.length pkt.data) in
+	header ^ pkt.data
+
+let unpack pkt =
+	pkt.tid, pkt.rid, pkt.ty, pkt.data
+
+let get_tid pkt = pkt.tid
+let get_ty pkt = pkt.ty
+let get_data pkt =
+	let l = String.length pkt.data in
+	if l > 0 && pkt.data.[l - 1] = '\000' then
+		String.sub pkt.data 0 (l - 1)
+	else
+		pkt.data
+let get_rid pkt = pkt.rid

tools/ocaml/libs/xb/partial.ml

@@ -0,0 +1,44 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+type pkt =
+{
+	tid: int;
+	rid: int;
+	ty: Op.operation;
+	len: int;
+	buf: Buffer.t;
+}
+
+external header_size: unit -> int = "stub_header_size"
+external header_of_string_internal: string -> int * int * int * int
+         = "stub_header_of_string"
+
+let of_string s =
+	let tid, rid, opint, dlen = header_of_string_internal s in
+	{
+		tid = tid;
+		rid = rid;
+		ty = (Op.of_cval opint);
+		len = dlen;
+		buf = Buffer.create dlen;
+	}
+
+let append pkt s sz =
+	Buffer.add_string pkt.buf (String.sub s 0 sz)
+
+let to_complete pkt =
+	pkt.len - (Buffer.length pkt.buf)

tools/ocaml/libs/xb/xb.ml

@@ -0,0 +1,189 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+module Op = struct include Op end
+module Packet = struct include Packet end
+
+exception End_of_file
+exception Eagain
+exception Noent
+exception Invalid
+
+type backend_mmap =
+{
+	mmap: Mmap.mmap_interface;     (* mmaped interface = xs_ring *)
+	eventchn_notify: unit -> unit; (* function to notify through eventchn *)
+	mutable work_again: bool;
+}
+
+type backend_fd =
+{
+	fd: Unix.file_descr;
+}
+
+type backend = Fd of backend_fd | Mmap of backend_mmap
+
+type partial_buf = HaveHdr of Partial.pkt | NoHdr of int * string
+
+type t =
+{
+	backend: backend;
+	pkt_in: Packet.t Queue.t;
+	pkt_out: Packet.t Queue.t;
+	mutable partial_in: partial_buf;
+	mutable partial_out: string;
+}
+
+let init_partial_in () = NoHdr
+	(Partial.header_size (), String.make (Partial.header_size()) '\000')
+
+let queue con pkt = Queue.push pkt con.pkt_out
+
+let read_fd back con s len =
+	let rd = Unix.read back.fd s 0 len in
+	if rd = 0 then
+		raise End_of_file;
+	rd
+
+let read_mmap back con s len =
+	let rd = Xs_ring.read back.mmap s len in
+	back.work_again <- (rd > 0);
+	if rd > 0 then
+		back.eventchn_notify ();
+	rd
+
+let read con s len =
+	match con.backend with
+	| Fd backfd     -> read_fd backfd con s len
+	| Mmap backmmap -> read_mmap backmmap con s len
+
+let write_fd back con s len =
+	Unix.write back.fd s 0 len
+
+let write_mmap back con s len =
+	let ws = Xs_ring.write back.mmap s len in
+	if ws > 0 then
+		back.eventchn_notify ();
+	ws
+
+let write con s len =
+	match con.backend with
+	| Fd backfd     -> write_fd backfd con s len
+	| Mmap backmmap -> write_mmap backmmap con s len
+
+let output con =
+	(* get the output string from a string_of(packet) or partial_out *)
+	let s = if String.length con.partial_out > 0 then
+			con.partial_out
+		else if Queue.length con.pkt_out > 0 then
+			Packet.to_string (Queue.pop con.pkt_out)
+		else
+			"" in
+	(* send data from s, and save the unsent data to partial_out *)
+	if s <> "" then (
+		let len = String.length s in
+		let sz = write con s len in
+		let left = String.sub s sz (len - sz) in
+		con.partial_out <- left
+	);
+	(* after sending one packet, partial is empty *)
+	con.partial_out = ""
+
+let input con =
+	let newpacket = ref false in
+	let to_read =
+		match con.partial_in with
+		| HaveHdr partial_pkt -> Partial.to_complete partial_pkt
+		| NoHdr   (i, buf)    -> i in
+
+	(* try to get more data from input stream *)
+	let s = String.make to_read '\000' in
+	let sz = if to_read > 0 then read con s to_read else 0 in
+
+	(
+	match con.partial_in with
+	| HaveHdr partial_pkt ->
+		(* we complete the data *)
+		if sz > 0 then
+			Partial.append partial_pkt s sz;
+		if Partial.to_complete partial_pkt = 0 then (
+			let pkt = Packet.of_partialpkt partial_pkt in
+			con.partial_in <- init_partial_in ();
+			Queue.push pkt con.pkt_in;
+			newpacket := true
+		)
+	| NoHdr (i, buf)      ->
+		(* we complete the partial header *)
+		if sz > 0 then
+			String.blit s 0 buf (Partial.header_size () - i) sz;
+		con.partial_in <- if sz = i then
+			HaveHdr (Partial.of_string buf) else NoHdr (i - sz, buf)
+	);
+	!newpacket
+
+let newcon backend = {
+	backend = backend;
+	pkt_in = Queue.create ();
+	pkt_out = Queue.create ();
+	partial_in = init_partial_in ();
+	partial_out = "";
+	}
+
+let open_fd fd = newcon (Fd { fd = fd; })
+
+let open_mmap mmap notifyfct =
+	newcon (Mmap {
+		mmap = mmap;
+		eventchn_notify = notifyfct;
+		work_again = false; })
+
+let close con =
+	match con.backend with
+	| Fd backend   -> Unix.close backend.fd
+	| Mmap backend -> Mmap.unmap backend.mmap
+
+let is_fd con =
+	match con.backend with
+	| Fd _   -> true
+	| Mmap _ -> false
+
+let is_mmap con = not (is_fd con)
+
+let output_len con = Queue.length con.pkt_out
+let has_new_output con = Queue.length con.pkt_out > 0
+let has_old_output con = String.length con.partial_out > 0
+
+let has_output con = has_new_output con || has_old_output con
+
+let peek_output con = Queue.peek con.pkt_out
+
+let input_len con = Queue.length con.pkt_in
+let has_in_packet con = Queue.length con.pkt_in > 0
+let get_in_packet con = Queue.pop con.pkt_in
+let has_more_input con =
+	match con.backend with
+	| Fd _         -> false
+	| Mmap backend -> backend.work_again
+
+let is_selectable con =
+	match con.backend with
+	| Fd _   -> true
+	| Mmap _ -> false
+
+let get_fd con =
+	match con.backend with
+	| Fd backend -> backend.fd
+	| Mmap _     -> raise (Failure "get_fd")

tools/ocaml/libs/xb/xb.mli

@@ -0,0 +1,83 @@
+module Op:
+sig
+	type operation = Op.operation =
+		| Debug
+		| Directory
+		| Read
+		| Getperms
+		| Watch
+		| Unwatch
+		| Transaction_start
+		| Transaction_end
+		| Introduce
+		| Release
+		| Getdomainpath
+		| Write
+		| Mkdir
+		| Rm
+		| Setperms
+		| Watchevent
+		| Error
+		| Isintroduced
+		| Resume
+		| Set_target
+		| Restrict
+	val to_string : operation -> string
+end
+
+module Packet:
+sig
+	type t
+
+	exception Error of string
+	exception DataError of string
+
+	val create : int -> int -> Op.operation -> string -> t
+	val unpack : t -> int * int * Op.operation * string
+
+	val get_tid : t -> int
+	val get_ty : t -> Op.operation
+	val get_data : t -> string
+	val get_rid: t -> int
+end
+
+exception End_of_file
+exception Eagain
+exception Noent
+exception Invalid
+
+type t
+
+(** queue a packet into the output queue for later sending *)
+val queue : t -> Packet.t -> unit
+
+(** process the output queue, return if a packet has been totally sent *)
+val output : t -> bool
+
+(** process the input queue, return if a packet has been totally received *)
+val input : t -> bool
+
+(** create new connection using a fd interface *)
+val open_fd : Unix.file_descr -> t
+(** create new connection using a mmap intf and a function to notify eventchn *)
+val open_mmap : Mmap.mmap_interface -> (unit -> unit) -> t
+
+(* close a connection *)
+val close : t -> unit
+
+val is_fd : t -> bool
+val is_mmap : t -> bool
+
+val output_len : t -> int
+val has_new_output : t -> bool
+val has_old_output : t -> bool
+val has_output : t -> bool
+val peek_output : t -> Packet.t
+
+val input_len : t -> int
+val has_in_packet : t -> bool
+val get_in_packet : t -> Packet.t
+val has_more_input : t -> bool
+
+val is_selectable : t -> bool
+val get_fd : t -> Unix.file_descr

tools/ocaml/libs/xb/xb_stubs.c

@@ -0,0 +1,74 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ */
+
+#include <unistd.h>
+#include <stdlib.h>
+#include <sys/mman.h>
+#include <string.h>
+#include <errno.h>
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+#define __XEN_TOOLS__
+
+#include <xenctrl.h>
+#define u32 uint32_t
+#include <xen/io/xs_wire.h>
+
+CAMLprim value stub_header_size(void)
+{
+	CAMLparam0();
+	CAMLreturn(Val_int(sizeof(struct xsd_sockmsg)));
+}
+
+CAMLprim value stub_header_of_string(value s)
+{
+	CAMLparam1(s);
+	CAMLlocal1(ret);
+	struct xsd_sockmsg *hdr;
+
+	if (caml_string_length(s) != sizeof(struct xsd_sockmsg))
+		caml_failwith("xb header incomplete");
+	ret = caml_alloc_tuple(4);
+	hdr = (struct xsd_sockmsg *) String_val(s);
+	Store_field(ret, 0, Val_int(hdr->tx_id));
+	Store_field(ret, 1, Val_int(hdr->req_id));
+	Store_field(ret, 2, Val_int(hdr->type));
+	Store_field(ret, 3, Val_int(hdr->len));
+	CAMLreturn(ret);
+}
+
+CAMLprim value stub_string_of_header(value tid, value rid, value ty, value len)
+{
+	CAMLparam4(tid, rid, ty, len);
+	CAMLlocal1(ret);
+	struct xsd_sockmsg xsd = {
+		.type = Int_val(ty),
+		.tx_id = Int_val(tid),
+		.req_id = Int_val(rid),
+		.len = Int_val(len),
+	};
+
+	ret = caml_alloc_string(sizeof(struct xsd_sockmsg));
+	memcpy(String_val(ret), &xsd, sizeof(struct xsd_sockmsg));
+
+	CAMLreturn(ret);
+}

tools/ocaml/libs/xb/xs_ring.ml

@@ -0,0 +1,18 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+external read: Mmap.mmap_interface -> string -> int -> int = "ml_interface_read"
+external write: Mmap.mmap_interface -> string -> int -> int = "ml_interface_write"

tools/ocaml/libs/xb/xs_ring_stubs.c

@@ -0,0 +1,117 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ */
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <errno.h>
+#include <string.h>
+
+#define __XEN_TOOLS__
+
+#include <xenctrl.h>
+#define u32 uint32_t
+#include <xen/io/xs_wire.h>
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+#include "mmap_stubs.h"
+
+#define GET_C_STRUCT(a) ((struct mmap_interface *) a)
+
+#ifndef xen_mb
+#define xen_mb()	mb()
+#endif
+
+static int xs_ring_read(struct mmap_interface *interface,
+                             char *buffer, int len)
+{
+	struct xenstore_domain_interface *intf = interface->addr;
+	XENSTORE_RING_IDX cons, prod;
+	int to_read;
+
+	cons = intf->req_cons;
+	prod = intf->req_prod;
+	xen_mb();
+	if (prod == cons)
+		return 0;
+	if (MASK_XENSTORE_IDX(prod) > MASK_XENSTORE_IDX(cons)) 
+		to_read = prod - cons;
+	else
+		to_read = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(cons);
+	if (to_read < len)
+		len = to_read;
+	memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), len);
+	xen_mb();
+	intf->req_cons += len;
+	return len;
+}
+
+static int xs_ring_write(struct mmap_interface *interface,
+                              char *buffer, int len)
+{
+	struct xenstore_domain_interface *intf = interface->addr;
+	XENSTORE_RING_IDX cons, prod;
+	int can_write;
+
+	cons = intf->rsp_cons;
+	prod = intf->rsp_prod;
+	xen_mb();
+	if ( (prod - cons) >= XENSTORE_RING_SIZE )
+		return 0;
+	if (MASK_XENSTORE_IDX(prod) >= MASK_XENSTORE_IDX(cons))
+		can_write = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(prod);
+	else 
+		can_write = MASK_XENSTORE_IDX(cons) - MASK_XENSTORE_IDX(prod);
+	if (can_write < len)
+		len = can_write;
+	memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, len);
+	xen_mb();
+	intf->rsp_prod += len;
+	return len;
+}
+
+CAMLprim value ml_interface_read(value interface, value buffer, value len)
+{
+	CAMLparam3(interface, buffer, len);
+	CAMLlocal1(result);
+	int res;
+
+	res = xs_ring_read(GET_C_STRUCT(interface),
+	                   String_val(buffer), Int_val(len));
+	if (res == -1)
+		caml_failwith("huh");
+	result = Val_int(res);
+	CAMLreturn(result);
+}
+
+CAMLprim value ml_interface_write(value interface, value buffer, value len)
+{
+	CAMLparam3(interface, buffer, len);
+	CAMLlocal1(result);
+	int res;
+
+	res = xs_ring_write(GET_C_STRUCT(interface),
+	                    String_val(buffer), Int_val(len));
+	result = Val_int(res);
+	CAMLreturn(result);
+}

tools/ocaml/libs/xs/META.in

@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "XenStore Interface"
+archive(byte) = "xs.cma"
+archive(native) = "xs.cmxa"

tools/ocaml/libs/xs/Makefile

@@ -0,0 +1,42 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OCAMLINCLUDE += -I ../xb/
+
+.NOTPARALLEL:
+# Ocaml is such a PITA!
+
+PREINTF = xsraw.cmi xst.cmi
+PREOBJS = queueop xsraw xst
+PRELIBS = $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJBS),$(obj).cmx)
+OBJS = queueop xsraw xst xs
+INTF = xsraw.cmi xst.cmi xs.cmi
+LIBS = xs.cma xs.cmxa
+
+all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+xs_OBJS = $(OBJS)
+OCAML_NOC_LIBRARY = xs
+
+#xs.cmxa: $(foreach obj,$(OBJS),$(obj).cmx)
+#	$(E) " MLLIB     $@"
+#	$(Q)$(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx)
+#
+#xs.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+#	$(E) " MLLIB     $@"
+#	$(Q)$(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+.PHONY: install
+install: $(LIBS) META
+	ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xs META $(INTF) xs.mli xst.mli xsraw.mli $(LIBS) *.a *.cmx
+
+.PHONY: uninstall
+uninstall:
+	ocamlfind remove xs
+
+include $(TOPLEVEL)/Makefile.rules
+

tools/ocaml/libs/xs/queueop.ml

@@ -0,0 +1,73 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+let data_concat ls = (String.concat "\000" ls) ^ "\000"
+let queue_path ty (tid: int) (path: string) con =
+	let data = data_concat [ path; ] in
+	Xb.queue con (Xb.Packet.create tid 0 ty data)
+
+(* operations *)
+let directory tid path con = queue_path Xb.Op.Directory tid path con
+let read tid path con = queue_path Xb.Op.Read tid path con
+
+let getperms tid path con = queue_path Xb.Op.Getperms tid path con
+
+let debug commands con =
+	Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands))
+
+let watch path data con =
+	let data = data_concat [ path; data; ] in
+	Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Watch data)
+
+let unwatch path data con =
+	let data = data_concat [ path; data; ] in
+	Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data)
+
+let transaction_start con =
+	Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat []))
+
+let transaction_end tid commit con =
+	let data = data_concat [ (if commit then "T" else "F"); ] in
+	Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data)
+
+let introduce domid mfn port con =
+	let data = data_concat [ Printf.sprintf "%u" domid;
+	                         Printf.sprintf "%nu" mfn;
+	                         string_of_int port; ] in
+	Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data)
+
+let release domid con =
+	let data = data_concat [ Printf.sprintf "%u" domid; ] in
+	Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Release data)
+
+let resume domid con =
+	let data = data_concat [ Printf.sprintf "%u" domid; ] in
+	Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Resume data)
+
+let getdomainpath domid con =
+	let data = data_concat [ Printf.sprintf "%u" domid; ] in
+	Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data)
+
+let write tid path value con =
+	let data = path ^ "\000" ^ value (* no NULL at the end *) in
+	Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Write data)
+
+let mkdir tid path con = queue_path Xb.Op.Mkdir tid path con
+let rm tid path con = queue_path Xb.Op.Rm tid path con
+
+let setperms tid path perms con =
+	let data = data_concat [ path; perms ] in
+	Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data)

tools/ocaml/libs/xs/xs.ml

@@ -0,0 +1,170 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+type perms = Xsraw.perms
+type con = Xsraw.con
+type domid = int
+
+type xsh =
+{
+	con: con;
+	debug: string list -> string;
+	directory: string -> string list;
+	read: string -> string;
+	readv: string -> string list -> string list;
+	write: string -> string -> unit;
+	writev: string -> (string * string) list -> unit;
+	mkdir: string -> unit;
+	rm: string -> unit;
+	getperms: string -> perms;
+	setperms: string -> perms -> unit;
+	setpermsv: string -> string list -> perms -> unit;
+	introduce: domid -> nativeint -> int -> unit;
+	release: domid -> unit;
+	resume: domid -> unit;
+	getdomainpath: domid -> string;
+	watch: string -> string -> unit;
+	unwatch: string -> string -> unit;
+}
+
+let get_operations con = {
+	con = con;
+	debug = (fun commands -> Xsraw.debug commands con);
+	directory = (fun path -> Xsraw.directory 0 path con);
+	read = (fun path -> Xsraw.read 0 path con);
+	readv = (fun dir vec -> Xsraw.readv 0 dir vec con);
+	write = (fun path value -> Xsraw.write 0 path value con);
+	writev = (fun dir vec -> Xsraw.writev 0 dir vec con);
+	mkdir = (fun path -> Xsraw.mkdir 0 path con);
+	rm = (fun path -> Xsraw.rm 0 path con);
+	getperms = (fun path -> Xsraw.getperms 0 path con);
+	setperms = (fun path perms -> Xsraw.setperms 0 path perms con);
+	setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con);
+	introduce = (fun id mfn port -> Xsraw.introduce id mfn port con);
+	release = (fun id -> Xsraw.release id con);
+	resume = (fun id -> Xsraw.resume id con);
+	getdomainpath = (fun id -> Xsraw.getdomainpath id con);
+	watch = (fun path data -> Xsraw.watch path data con);
+	unwatch = (fun path data -> Xsraw.unwatch path data con);
+}
+
+let transaction xsh = Xst.transaction xsh.con
+
+let has_watchevents xsh = Xsraw.has_watchevents xsh.con
+let get_watchevent xsh = Xsraw.get_watchevent xsh.con
+
+let read_watchevent xsh = Xsraw.read_watchevent xsh.con
+
+let make fd = get_operations (Xsraw.open_fd fd)
+let get_fd xsh = Xb.get_fd xsh.con.Xsraw.xb
+
+exception Timeout
+
+(* Should never be thrown, indicates a bug in the read_watchevent_timetout function *)
+exception Timeout_with_nonempty_queue
+
+(* Just in case we screw up: poll the callback every couple of seconds rather
+   than wait for the whole timeout period *)
+let max_blocking_time = 5. (* seconds *)
+
+let read_watchevent_timeout xsh timeout callback =
+	let start_time = Unix.gettimeofday () in
+	let end_time = start_time +. timeout in
+
+	let left = ref timeout in
+
+	(* Returns true if a watch event in the queue satisfied us *)
+	let process_queued_events () = 
+		let success = ref false in
+		while Xsraw.has_watchevents xsh.con && not(!success)
+		do
+			success := callback (Xsraw.get_watchevent xsh.con)
+		done;
+		!success in
+	(* Returns true if a watch event read from the socket satisfied us *)
+	let process_incoming_event () = 
+		let fd = get_fd xsh in
+		let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time !left) in
+
+		(* If data is available for reading then read it *)
+		if r = []
+		then false (* timeout, either a max_blocking_time or global *)
+		else callback (Xsraw.read_watchevent xsh.con) in
+
+	let success = ref false in
+	while !left > 0. && not(!success)
+	do
+		(* NB the 'callback' might call back into Xs functions
+		   and as a side-effect, watches might be queued. Hence
+		   we must process the queue on every loop iteration *)
+
+		(* First process all queued watch events *)
+		if not(!success)
+		then success := process_queued_events ();
+		(* Then block for one more watch event *)
+		if not(!success)
+		then success := process_incoming_event ();
+		(* Just in case our callback caused events to be queued
+		   and this is our last time round the loop: this prevents
+		   us throwing the Timeout_with_nonempty_queue spuriously *)
+		if not(!success)
+		then success := process_queued_events ();
+
+		(* Update the time left *)
+		let current_time = Unix.gettimeofday () in
+		left := end_time -. current_time
+	done;
+	if not(!success) then begin
+		(* Sanity check: it should be impossible for any
+		   events to be queued here *)
+		if Xsraw.has_watchevents xsh.con
+		then raise Timeout_with_nonempty_queue
+		else raise Timeout
+	end
+
+
+let monitor_paths xsh l time callback =
+	let unwatch () =
+		List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in
+	List.iter (fun (w,v) -> xsh.watch w v) l;
+	begin try
+		read_watchevent_timeout xsh time callback;
+	with
+		exn -> unwatch (); raise exn;
+	end;
+	unwatch ()
+
+let daemon_socket = "/var/run/xenstored/socket"
+
+(** Throws this rather than a miscellaneous Unix.connect failed *)
+exception Failed_to_connect
+
+let daemon_open () =
+	try
+		let sockaddr = Unix.ADDR_UNIX(daemon_socket) in
+		let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+		Unix.connect sock sockaddr;
+		Unix.set_close_on_exec sock;
+		make sock
+	with _ -> raise Failed_to_connect
+
+let domain_open () =
+	let path = "/proc/xen/xenbus" in
+	let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in
+	Unix.set_close_on_exec fd;
+	make fd
+
+let close xsh = Xsraw.close xsh.con

tools/ocaml/libs/xs/xs.mli

@@ -0,0 +1,90 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+exception Timeout
+
+(** Throws this rather than a miscellaneous Unix.connect failed *)
+exception Failed_to_connect
+
+(** perms contains 3 things:
+    - owner domid.
+    - other perm: applied to domain that is not owner or in ACL.
+    - ACL: list of per-domain permission
+  *)
+type perms = Xsraw.perms
+
+type domid = int
+type con
+
+type xsh = {
+	con : con;
+	debug: string list -> string;
+	directory : string -> string list;
+	read : string -> string;
+	readv : string -> string list -> string list;
+	write : string -> string -> unit;
+	writev : string -> (string * string) list -> unit;
+	mkdir : string -> unit;
+	rm : string -> unit;
+	getperms : string -> perms;
+	setperms : string -> perms -> unit;
+	setpermsv : string -> string list -> perms -> unit;
+	introduce : domid -> nativeint -> int -> unit;
+	release : domid -> unit;
+	resume : domid -> unit;
+	getdomainpath : domid -> string;
+	watch : string -> string -> unit;
+	unwatch : string -> string -> unit;
+}
+
+(** get operations provide a vector of xenstore function that apply to one
+    connection *)
+val get_operations : con -> xsh
+
+(** create a transaction with a vector of function that can be applied
+    into the transaction. *)
+val transaction : xsh -> (Xst.ops -> 'a) -> 'a
+
+(** watch manipulation on a connection *)
+val has_watchevents : xsh -> bool
+val get_watchevent : xsh -> string * string
+val read_watchevent : xsh -> string * string
+
+(** get_fd return the fd of the connection to be able to select on it.
+    NOTE: it works only for socket-based connection *)
+val get_fd : xsh -> Unix.file_descr
+
+(** wait for watchevent with a timeout. Until the callback return true,
+    every watch during the time specified, will be pass to the callback.
+    NOTE: it works only when use with a socket-based connection *)
+val read_watchevent_timeout : xsh -> float -> (string * string -> bool) -> unit
+
+(** register a set of watches, then wait for watchevent.
+    remove all watches previously set before giving back the hand. *)
+val monitor_paths : xsh
+                 -> (string * string) list
+                 -> float
+                 -> (string * string -> bool)
+                 -> unit
+
+(** open a socket-based xenstored connection *)
+val daemon_open : unit -> xsh
+
+(** open a mmap-based xenstored connection *)
+val domain_open : unit -> xsh
+
+(** close any xenstored connection *)
+val close : xsh -> unit

tools/ocaml/libs/xs/xsraw.ml

@@ -0,0 +1,265 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+exception Partial_not_empty
+exception Unexpected_packet of string
+
+(** Thrown when a path looks invalid e.g. if it contains "//" *)
+exception Invalid_path of string
+
+let unexpected_packet expected received =
+	let s = Printf.sprintf "expecting %s received %s"
+	                       (Xb.Op.to_string expected)
+	                       (Xb.Op.to_string received) in
+	raise (Unexpected_packet s)
+
+type con = {
+	xb: Xb.t;
+	watchevents: (string * string) Queue.t;
+}
+
+let close con =
+	Xb.close con.xb
+
+let open_fd fd = {
+	xb = Xb.open_fd fd;
+	watchevents = Queue.create ();
+}
+
+let rec split_string ?limit:(limit=(-1)) c s =
+	let i = try String.index s c with Not_found -> -1 in
+	let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in
+	if i = -1 || nlimit = 0 then
+		[ s ]
+	else
+		let a = String.sub s 0 i
+		and b = String.sub s (i + 1) (String.length s - i - 1) in
+		a :: (split_string ~limit: nlimit c b)
+
+type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR
+
+type perms = int * perm * (int * perm) list
+
+let string_of_perms perms =
+	let owner, other, acl = perms in
+	let char_of_perm perm =
+		match perm with PERM_NONE -> 'n' | PERM_READ -> 'r'
+			      | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in
+	let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm perm) id in
+	String.concat "\000" (List.map string_of_perm ((owner,other) :: acl))
+
+let perms_of_string s =
+	let perm_of_char c =
+		match c with 'n' -> PERM_NONE | 'r' -> PERM_READ
+		           | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR
+		           | c -> invalid_arg (Printf.sprintf "unknown permission type: %c" c) in
+	let perm_of_string s =
+		if String.length s < 2 
+		then invalid_arg (Printf.sprintf "perm of string: length = %d; contents=\"%s\"" (String.length s) s) 
+		else
+		begin
+			int_of_string (String.sub s 1 (String.length s - 1)),
+			perm_of_char s.[0]
+		end in
+	let rec split s =
+		try let i = String.index s '\000' in
+		String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 - i))
+		with Not_found -> if s = "" then [] else [ s ] in
+	let l = List.map perm_of_string (split s) in
+	match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, [])
+
+(* send one packet - can sleep *)
+let pkt_send con =
+	if Xb.has_old_output con.xb then
+		raise Partial_not_empty;
+	let workdone = ref false in
+	while not !workdone
+	do
+		workdone := Xb.output con.xb
+	done
+
+(* receive one packet - can sleep *)
+let pkt_recv con =
+	let workdone = ref false in
+	while not !workdone
+	do
+		workdone := Xb.input con.xb
+	done;
+	Xb.get_in_packet con.xb
+
+let pkt_recv_timeout con timeout =
+	let fd = Xb.get_fd con.xb in
+	let r, _, _ = Unix.select [ fd ] [] [] timeout in
+	if r = [] then
+		true, None
+	else (
+		let workdone = Xb.input con.xb in
+		if workdone then
+			false, (Some (Xb.get_in_packet con.xb))
+		else
+			false, None
+	)
+
+let queue_watchevent con data =
+	let ls = split_string ~limit:2 '\000' data in
+	if List.length ls != 2 then
+		raise (Xb.Packet.DataError "arguments number mismatch");
+	let event = List.nth ls 0
+	and event_data = List.nth ls 1 in
+	Queue.push (event, event_data) con.watchevents
+
+let has_watchevents con = Queue.length con.watchevents > 0
+let get_watchevent con = Queue.pop con.watchevents
+
+let read_watchevent con =
+	let pkt = pkt_recv con in
+	match Xb.Packet.get_ty pkt with
+	| Xb.Op.Watchevent ->
+		queue_watchevent con (Xb.Packet.get_data pkt);
+		Queue.pop con.watchevents
+	| ty               -> unexpected_packet Xb.Op.Watchevent ty
+
+(* send one packet in the queue, and wait for reply *)
+let rec sync_recv ty con =
+	let pkt = pkt_recv con in
+	match Xb.Packet.get_ty pkt with
+	| Xb.Op.Error       -> (
+		match Xb.Packet.get_data pkt with
+		| "ENOENT" -> raise Xb.Noent
+		| "EAGAIN" -> raise Xb.Eagain
+		| "EINVAL" -> raise Xb.Invalid
+		| s        -> raise (Xb.Packet.Error s))
+	| Xb.Op.Watchevent  ->
+		queue_watchevent con (Xb.Packet.get_data pkt);
+		sync_recv ty con
+	| rty when rty = ty -> Xb.Packet.get_data pkt
+	| rty               -> unexpected_packet ty rty
+
+let sync f con =
+	(* queue a query using function f *)
+	f con.xb;
+	if Xb.output_len con.xb = 0 then
+		Printf.printf "output len = 0\n%!";
+	let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in
+	pkt_send con;
+	sync_recv ty con
+
+let ack s =
+	if s = "OK" then () else raise (Xb.Packet.DataError s)
+
+(** Check paths are suitable for read/write/mkdir/rm/directory etc (NOT watches) *)
+let validate_path path =
+	(* Paths shouldn't have a "//" in the middle *)
+	let bad = "//" in
+	for offset = 0 to String.length path - (String.length bad) do
+		if String.sub path offset (String.length bad) = bad then
+			raise (Invalid_path path)
+	done;
+	(* Paths shouldn't have a "/" at the end, except for the root *)
+	if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then
+		raise (Invalid_path path)
+
+(** Check to see if a path is suitable for watches *)
+let validate_watch_path path =
+	(* Check for stuff like @releaseDomain etc first *)
+	if path <> "" && path.[0] = '@' then ()
+	else validate_path path
+
+let debug command con =
+	sync (Queueop.debug command) con
+
+let directory tid path con =
+	validate_path path;
+	let data = sync (Queueop.directory tid path) con in
+	split_string '\000' data
+
+let read tid path con =
+	validate_path path;
+	sync (Queueop.read tid path) con
+
+let readv tid dir vec con =
+	List.map (fun path -> validate_path path; read tid path con)
+		(if dir <> "" then
+			(List.map (fun v -> dir ^ "/" ^ v) vec) else vec)
+
+let getperms tid path con =
+	validate_path path;
+	perms_of_string (sync (Queueop.getperms tid path) con)
+
+let watch path data con =
+	validate_watch_path path;
+	ack (sync (Queueop.watch path data) con)
+
+let unwatch path data con =
+	validate_watch_path path;
+	ack (sync (Queueop.unwatch path data) con)
+
+let transaction_start con =
+	let data = sync (Queueop.transaction_start) con in
+	try
+		int_of_string data
+	with
+		_ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" data))
+
+let transaction_end tid commit con =
+	try
+		ack (sync (Queueop.transaction_end tid commit) con);
+		true
+	with
+		Xb.Eagain -> false
+
+let introduce domid mfn port con =
+	ack (sync (Queueop.introduce domid mfn port) con)
+
+let release domid con =
+	ack (sync (Queueop.release domid) con)
+
+let resume domid con =
+	ack (sync (Queueop.resume domid) con)
+
+let getdomainpath domid con =
+	sync (Queueop.getdomainpath domid) con
+
+let write tid path value con =
+	validate_path path;
+	ack (sync (Queueop.write tid path value) con)
+
+let writev tid dir vec con =
+	List.iter (fun (entry, value) ->
+		let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
+                validate_path path;
+		write tid path value con) vec
+
+let mkdir tid path con =
+	validate_path path;
+	ack (sync (Queueop.mkdir tid path) con)
+
+let rm tid path con =
+        validate_path path;
+	try
+		ack (sync (Queueop.rm tid path) con)
+	with
+		Xb.Noent -> ()
+
+let setperms tid path perms con =
+	validate_path path;
+	ack (sync (Queueop.setperms tid path (string_of_perms perms)) con)
+
+let setpermsv tid dir vec perms con =
+	List.iter (fun entry ->
+		let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
+		validate_path path;
+		setperms tid path perms con) vec

tools/ocaml/libs/xs/xsraw.mli

@@ -0,0 +1,60 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+exception Partial_not_empty
+exception Unexpected_packet of string
+exception Invalid_path of string
+val unexpected_packet : Xb.Op.operation -> Xb.Op.operation -> 'a
+type con = { xb : Xb.t; watchevents : (string * string) Queue.t; }
+val close : con -> unit
+val open_fd : Unix.file_descr -> con
+val split_string : ?limit:int -> char -> string -> string list
+type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR
+type perms = int * perm * (int * perm) list
+val string_of_perms : int * perm * (int * perm) list -> string
+val perms_of_string : string -> int * perm * (int * perm) list
+val pkt_send : con -> unit
+val pkt_recv : con -> Xb.Packet.t
+val pkt_recv_timeout : con -> float -> bool * Xb.Packet.t option
+val queue_watchevent : con -> string -> unit
+val has_watchevents : con -> bool
+val get_watchevent : con -> string * string
+val read_watchevent : con -> string * string
+val sync_recv : Xb.Op.operation -> con -> string
+val sync : (Xb.t -> 'a) -> con -> string
+val ack : string -> unit
+val validate_path : string -> unit
+val validate_watch_path : string -> unit
+val directory : int -> string -> con -> string list
+val debug : string list -> con -> string
+val read : int -> string -> con -> string
+val readv : int -> string -> string list -> con -> string list
+val getperms : int -> string -> con -> int * perm * (int * perm) list
+val watch : string -> string -> con -> unit
+val unwatch : string -> string -> con -> unit
+val transaction_start : con -> int
+val transaction_end : int -> bool -> con -> bool
+val introduce : int -> nativeint -> int -> con -> unit
+val release : int -> con -> unit
+val resume : int -> con -> unit
+val getdomainpath : int -> con -> string
+val write : int -> string -> string -> con -> unit
+val writev : int -> string -> (string * string) list -> con -> unit
+val mkdir : int -> string -> con -> unit
+val rm : int -> string -> con -> unit
+val setperms : int -> string -> int * perm * (int * perm) list -> con -> unit
+val setpermsv :
+  int ->
+  string -> string list -> int * perm * (int * perm) list -> con -> unit

tools/ocaml/libs/xs/xst.ml

@@ -0,0 +1,61 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+
+type ops =
+{
+	directory: string -> string list;
+	read: string -> string;
+	readv: string -> string list -> string list;
+	write: string -> string -> unit;
+	writev: string -> (string * string) list -> unit;
+	mkdir: string -> unit;
+	rm: string -> unit;
+	getperms: string -> Xsraw.perms;
+	setperms: string -> Xsraw.perms -> unit;
+	setpermsv: string -> string list -> Xsraw.perms -> unit;
+}
+
+let get_operations tid xsh = {
+	directory = (fun path -> Xsraw.directory tid path xsh);
+	read = (fun path -> Xsraw.read tid path xsh);
+	readv = (fun dir vec -> Xsraw.readv tid dir vec xsh);
+	write = (fun path value -> Xsraw.write tid path value xsh);
+	writev = (fun dir vec -> Xsraw.writev tid dir vec xsh);
+	mkdir = (fun path -> Xsraw.mkdir tid path xsh);
+	rm = (fun path -> Xsraw.rm tid path xsh);
+	getperms = (fun path -> Xsraw.getperms tid path xsh);
+	setperms = (fun path perms -> Xsraw.setperms tid path perms xsh);
+	setpermsv = (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xsh);
+}
+
+let transaction xsh (f: ops -> 'a) : 'a =
+	let commited = ref false and result = ref None in
+	while not !commited
+	do
+		let tid = Xsraw.transaction_start xsh in
+		let t = get_operations tid xsh in
+
+		begin try
+			result := Some (f t)
+		with exn ->
+			ignore (Xsraw.transaction_end tid false xsh);
+			raise exn
+		end;
+		commited := Xsraw.transaction_end tid true xsh
+	done;
+	match !result with
+	| None        -> failwith "internal error in transaction"
+	| Some result -> result

tools/ocaml/libs/xs/xst.mli

@@ -0,0 +1,30 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * 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.
+ *)
+type ops = {
+	directory : string -> string list;
+	read : string -> string;
+	readv : string -> string list -> string list;
+	write : string -> string -> unit;
+	writev : string -> (string * string) list -> unit;
+	mkdir : string -> unit;
+	rm : string -> unit;
+	getperms : string -> Xsraw.perms;
+	setperms : string -> Xsraw.perms -> unit;
+	setpermsv : string -> string list -> Xsraw.perms -> unit;
+}
+
+val get_operations : int -> Xsraw.con -> ops
+val transaction : Xsraw.con -> (ops -> 'a) -> 'a