Import from ocaml-xenstore 452a7ca5674faf393e2e4317cf2ff3a8087ca770

Makefile

@@ -0,0 +1,17 @@
+OS ?= unix
+
+ifneq "$(MIRAGE_OS)" ""
+OS := $(MIRAGE_OS)
+endif
+
+.PHONY: all clean install test
+.DEFAULT: all
+
+all:
+	cd $(OS) && $(MAKE) all
+clean:
+	cd $(OS) && $(MAKE) clean
+install:
+	cd $(OS) && $(MAKE) install
+test:
+	cd $(OS) && $(MAKE) test

_oasis

@@ -0,0 +1,28 @@
+OASISFormat: 0.2
+Name:        xenstore_servers
+Version:     0.9-dev
+Synopsis:    Xenstore servers (userspace and kernelspace)
+Authors:     Dave Scott, Anil Madhavapeddy
+License:     LGPL-2.1 with OCaml linking exception
+Plugins:     META (0.2)
+BuildTools:  ocamlbuild
+
+Library xenstore_unix
+  CompiledObject:     best
+  Path:               unix
+  Findlibname:        unix
+  FindlibParent:      xenstore
+  Modules:            Xs_transport_unix, Xs_transport_xen, Xenstore
+  BuildDepends:       lwt, xenstore, xenstore.server
+  CSources:           xenstore_stubs.c
+  CCOpt:              -I. -I/home/djs/.opam/system/lib -I/home/djs/.opam/system/lib/lwt -I/usr/lib/ocaml/lwt
+  CClib:              -lxenctrl
+
+Executable server_unix
+  CompiledObject:     best
+  Build$:             flag(unix)
+  Path:               server_unix
+  MainIs:             server_unix.ml
+  Custom:             true
+  Install:            false
+  BuildDepends:       lwt, lwt.unix, xenstore, xenstore.server, xenstore.unix

unix/Makefile

@@ -0,0 +1,34 @@
+.PHONY: all clean install build
+all: build doc
+
+NAME=xenstore
+J=4
+
+export OCAMLRUNPARAM=b
+
+setup.bin: setup.ml
+	@ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $<
+	@rm -f setup.cmx setup.cmi setup.o setup.cmo
+
+setup.data: setup.bin
+	@./setup.bin -configure
+
+build: setup.data setup.bin
+	@./setup.bin -build -j $(J)
+
+doc: setup.data setup.bin
+	@./setup.bin -doc -j $(J)
+
+install: setup.bin
+	@./setup.bin -install
+
+test: setup.bin build
+	@./setup.bin -test
+
+reinstall: setup.bin
+	@ocamlfind remove $(NAME) || true
+	@./setup.bin -reinstall
+
+clean:
+	@ocamlbuild -clean
+	@rm -f setup.data setup.log setup.bin

unix/_oasis

@@ -0,0 +1,27 @@
+OASISFormat: 0.2
+Name:        xenstore_servers
+Version:     0.9-dev
+Synopsis:    Userspace xenstore server
+Authors:     Dave Scott, Anil Madhavapeddy
+License:     LGPL-2.1 with OCaml linking exception
+Plugins:     META (0.2)
+BuildTools:  ocamlbuild
+
+Library xenstore_unix
+  CompiledObject:     best
+  Path:               lib
+  Findlibname:        xenstore_server_unix
+  Modules:            Xs_transport_unix, Xs_transport_xen, Xenstore
+  BuildDepends:       lwt, xenstore, xenstore.server
+  CSources:           xenstore_stubs.c
+  CCOpt:              -I. -I/home/djs/.opam/system/lib -I/home/djs/.opam/system/lib/lwt -I/usr/lib/ocaml/lwt
+  CClib:              -lxenctrl
+
+Executable server_unix
+  CompiledObject:     best
+  Build$:             flag(unix)
+  Path:               src
+  MainIs:             server_unix.ml
+  Custom:             true
+  Install:            false
+  BuildDepends:       lwt, lwt.unix, xenstore, xenstore.server, xenstore_server_unix

unix/lib/xenstore.ml

@@ -0,0 +1,98 @@
+
+external map_foreign_job: int -> nativeint -> Cstruct.buf Lwt_unix.job = "lwt_map_foreign_job"
+
+let map_foreign domid mfn = Lwt_unix.run_job (map_foreign_job domid mfn)
+
+external map_fd: Unix.file_descr -> int -> Cstruct.buf option = "ml_map_fd"
+
+external unmap_foreign: Cstruct.buf -> unit = "ml_unmap"
+
+external unsafe_read: Cstruct.buf -> string -> int -> int -> int = "ml_interface_read"
+external unsafe_write: Cstruct.buf -> string -> int -> int -> int = "ml_interface_write"
+
+type channel_state = {
+	cons: int;
+	prod: int;
+	data: int;
+}
+type ring_state = {
+	request: channel_state;
+	response: channel_state;
+}
+
+external get_ring_state: Cstruct.buf -> ring_state = "xs_ring_state"
+
+external sizeof_xc_domaininfo_t: unit -> int = "ml_sizeof_xc_domaininfo_t"
+
+external alloc_page_aligned: int -> Cstruct.buf option = "ml_alloc_page_aligned"
+
+external free_page_aligned: Cstruct.buf -> unit = "ml_free_page_aligned"
+
+external domain_infolist_job: int -> int -> Cstruct.buf -> int Lwt_unix.job = "lwt_domain_infolist_job"
+
+type info = {
+	domid: int;
+	dying: bool;
+	shutdown: bool;
+}
+
+external xc_domaininfo_t_parse: Cstruct.buf -> info = "ml_domain_infolist_parse"
+
+open Lwt
+
+let batch_size = 512 (* number of domains to query in one hypercall *)
+
+let xc_domain_getinfolist lowest_domid =
+	let sizeof = sizeof_xc_domaininfo_t () in
+	let buf = alloc_page_aligned (batch_size * sizeof) in
+	match buf with
+		| None -> return None
+		| Some buf ->
+			try_lwt
+				lwt number_found = Lwt_unix.run_job (domain_infolist_job lowest_domid batch_size buf) in
+				let rec parse buf n acc =
+					if n = number_found
+					then acc
+					else parse (Cstruct.shift buf sizeof) (n + 1) (xc_domaininfo_t_parse buf :: acc) in
+				return (Some(parse buf 0 []))
+			finally
+				return (free_page_aligned buf)
+
+let domain_infolist () =
+	let rec loop from =
+		lwt first = xc_domain_getinfolist from in
+		match first with
+			| None -> return None
+			| Some first ->
+				(* If we returned less than a batch then there are no more. *)
+				if List.length first < batch_size
+				then return (Some first)
+				else match first with
+					| [] -> return (Some [])
+					| x :: xs ->
+						(* Don't assume the last entry has the highest domid *)
+						let largest_domid = List.fold_left (fun domid di -> max domid di.domid) x.domid xs in
+						lwt rest = loop (largest_domid + 1) in
+						match rest with
+							| None -> return None
+							| Some rest -> return (Some (first @ rest)) in
+	loop 0
+
+type xc_evtchn
+external xc_evtchn_open: unit -> xc_evtchn option = "stub_xc_evtchn_open"
+
+external xc_evtchn_close: destroy: xc_evtchn -> unit = "stub_xc_evtchn_close"
+
+external xc_evtchn_fd: xc_evtchn -> Unix.file_descr option = "stub_xc_evtchn_fd"
+
+external xc_evtchn_notify: xc_evtchn -> int -> unit = "stub_xc_evtchn_notify"
+
+external xc_evtchn_bind_interdomain: xc_evtchn -> int -> int -> int option = "stub_xc_evtchn_bind_interdomain"
+
+external xc_evtchn_bind_virq_dom_exc: xc_evtchn -> int option = "stub_xc_evtchn_bind_virq_dom_exc"
+
+external xc_evtchn_unbind: xc_evtchn -> int -> unit = "stub_xc_evtchn_unbind"
+
+external xc_evtchn_pending: xc_evtchn -> int option = "stub_xc_evtchn_pending"
+
+external xc_evtchn_unmask: xc_evtchn -> int -> unit = "stub_xc_evtchn_unmask"

unix/lib/xenstore.mli

@@ -0,0 +1,47 @@
+
+val map_foreign: int -> nativeint -> Cstruct.buf Lwt.t
+val unmap_foreign: Cstruct.buf -> unit
+
+val map_fd: Unix.file_descr -> int -> Cstruct.buf option
+
+val unsafe_read: Cstruct.buf -> string -> int -> int -> int
+val unsafe_write: Cstruct.buf -> string -> int -> int -> int
+
+type channel_state = {
+	cons: int;
+	prod: int;
+	data: int;
+}
+type ring_state = {
+	request: channel_state;
+	response: channel_state;
+}
+
+val get_ring_state: Cstruct.buf -> ring_state
+
+type info = {
+	domid: int;
+	dying: bool;
+	shutdown: bool;
+}
+
+val domain_infolist: unit -> info list option Lwt.t
+
+type xc_evtchn
+val xc_evtchn_open: unit -> xc_evtchn option
+
+val xc_evtchn_close: destroy: xc_evtchn -> unit
+
+val xc_evtchn_fd: xc_evtchn -> Unix.file_descr option
+
+val xc_evtchn_notify: xc_evtchn -> int -> unit
+
+val xc_evtchn_bind_interdomain: xc_evtchn -> int -> int -> int option
+
+val xc_evtchn_bind_virq_dom_exc: xc_evtchn -> int option
+
+val xc_evtchn_unbind: xc_evtchn -> int -> unit
+
+val xc_evtchn_pending: xc_evtchn -> int option
+
+val xc_evtchn_unmask: xc_evtchn -> int -> unit