ocaml: Add xenstored implementation.

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

tools/ocaml/xenstored/Makefile

@@ -0,0 +1,54 @@
+OCAML_TOPLEVEL = ..
+include $(OCAML_TOPLEVEL)/common.make
+
+OCAMLINCLUDE += \
+	-I $(OCAML_TOPLEVEL)/libs/log \
+	-I $(OCAML_TOPLEVEL)/libs/xb \
+	-I $(OCAML_TOPLEVEL)/libs/uuid \
+	-I $(OCAML_TOPLEVEL)/libs/mmap \
+	-I $(OCAML_TOPLEVEL)/libs/xc \
+	-I $(OCAML_TOPLEVEL)/libs/eventchn
+
+OBJS = define \
+	stdext \
+	trie \
+	config \
+	logging \
+	quota \
+	perms \
+	symbol \
+	utils \
+	store \
+	disk \
+	transaction \
+	event \
+	domain \
+	domains \
+	connection \
+	connections \
+	parse_arg \
+	process \
+	xenstored
+
+INTF = symbol.cmi trie.cmi
+XENSTOREDLIBS = \
+	unix.cmxa \
+	$(OCAML_TOPLEVEL)/libs/uuid/uuid.cmxa \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/mmap.cmxa \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/log $(OCAML_TOPLEVEL)/libs/log/log.cmxa \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn $(OCAML_TOPLEVEL)/libs/eventchn/eventchn.cmxa \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc $(OCAML_TOPLEVEL)/libs/xc/xc.cmxa \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xb $(OCAML_TOPLEVEL)/libs/xb/xb.cmxa
+
+PROGRAMS = oxenstored
+
+oxenstored_LIBS = $(XENSTOREDLIBS)
+oxenstored_OBJS = $(OBJS)
+
+OCAML_PROGRAM = oxenstored
+
+all: $(INTF) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+include $(OCAML_TOPLEVEL)/Makefile.rules

tools/ocaml/xenstored/config.ml

@@ -0,0 +1,112 @@
+(*
+ * 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 ty =
+	| Set_bool of bool ref
+	| Set_int of int ref
+	| Set_string of string ref
+	| Set_float of float ref
+	| Unit of (unit -> unit)
+	| Bool of (bool -> unit)
+	| Int of (int -> unit)
+	| String of (string -> unit)
+	| Float of (float -> unit)
+
+exception Error of (string * string) list
+
+let trim_start lc s =
+	let len = String.length s and i = ref 0 in
+	while !i < len && (List.mem s.[!i] lc)
+	do
+		incr i
+	done;
+	if !i < len then String.sub s !i (len - !i) else ""
+
+let trim_end lc s =
+	let i = ref (String.length s - 1) in
+	while !i > 0 && (List.mem s.[!i] lc)
+	do
+		decr i
+	done;
+	if !i >= 0 then String.sub s 0 (!i + 1) else ""
+
+let rec split ?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 ~limit: nlimit c b)
+
+let parse_line stream =
+	let lc = [ ' '; '\t' ] in
+	let trim_spaces s = trim_end lc (trim_start lc s) in
+	let to_config s =
+		match split ~limit:2 '=' s with
+		| k :: v :: [] -> Some (trim_end lc k, trim_start lc v)
+		| _            -> None in
+	let rec read_filter_line () =
+		try
+			let line = trim_spaces (input_line stream) in
+			if String.length line > 0 && line.[0] <> '#' then
+				match to_config line with
+				| None   -> read_filter_line ()
+				| Some x -> x :: read_filter_line ()
+			else
+				read_filter_line ()
+		with
+			End_of_file -> [] in
+	read_filter_line ()
+
+let parse filename =
+	let stream = open_in filename in
+	let cf = parse_line stream in
+	close_in stream;
+	cf
+
+let validate cf expected other =
+	let err = ref [] in
+	let append x = err := x :: !err in
+	List.iter (fun (k, v) ->
+		try
+			if not (List.mem_assoc k expected) then
+				other k v
+			else let ty = List.assoc k expected in
+			match ty with
+			| Unit f       -> f ()
+			| Bool f       -> f (bool_of_string v)
+			| String f     -> f v
+			| Int f        -> f (int_of_string v)
+			| Float f      -> f (float_of_string v)
+			| Set_bool r   -> r := (bool_of_string v)
+			| Set_string r -> r := v
+			| Set_int r    -> r := int_of_string v
+			| Set_float r  -> r := (float_of_string v)
+		with
+		| Not_found                 -> append (k, "unknown key")
+		| Failure "int_of_string"   -> append (k, "expect int arg")
+		| Failure "bool_of_string"  -> append (k, "expect bool arg")
+		| Failure "float_of_string" -> append (k, "expect float arg")
+		| exn                       -> append (k, Printexc.to_string exn)
+		) cf;
+	if !err != [] then raise (Error !err)
+
+(** read a filename, parse and validate, and return the errors if any *)
+let read filename expected other =
+	let cf = parse filename in
+	validate cf expected other

tools/ocaml/xenstored/connection.ml

@@ -0,0 +1,234 @@
+(*
+ * 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 End_of_file
+
+open Stdext
+
+type watch = {
+	con: t;
+	token: string;
+	path: string;
+	base: string;
+	is_relative: bool;
+}
+
+and t = {
+	xb: Xb.t;
+	dom: Domain.t option;
+	transactions: (int, Transaction.t) Hashtbl.t;
+	mutable next_tid: int;
+	watches: (string, watch list) Hashtbl.t;
+	mutable nb_watches: int;
+	anonid: int;
+	mutable stat_nb_ops: int;
+	mutable perm: Perms.Connection.t;
+}
+
+let get_path con =
+Printf.sprintf "/local/domain/%i/" (match con.dom with None -> 0 | Some d -> Domain.get_id d)
+
+let watch_create ~con ~path ~token = { 
+	con = con; 
+	token = token; 
+	path = path; 
+	base = get_path con; 
+	is_relative = path.[0] <> '/' && path.[0] <> '@'
+}
+
+let get_con w = w.con
+ 
+let number_of_transactions con =
+	Hashtbl.length con.transactions
+
+let get_domain con = con.dom
+
+let anon_id_next = ref 1
+
+let get_domstr con =
+	match con.dom with
+	| None     -> "A" ^ (string_of_int con.anonid)
+	| Some dom -> "D" ^ (string_of_int (Domain.get_id dom))
+
+let make_perm dom =
+	let domid = 
+		match dom with
+		| None   -> 0
+		| Some d -> Domain.get_id d
+	in 
+	Perms.Connection.create ~perms:[Perms.READ; Perms.WRITE] domid
+
+let create xbcon dom =
+	let id =
+		match dom with
+		| None -> let old = !anon_id_next in incr anon_id_next; old
+		| Some _ -> 0  
+		in
+	let con = 
+	{
+	xb = xbcon;
+	dom = dom;
+	transactions = Hashtbl.create 5;
+	next_tid = 1;
+	watches = Hashtbl.create 8;
+	nb_watches = 0;
+	anonid = id;
+	stat_nb_ops = 0;
+	perm = make_perm dom;
+	}
+	in 
+	Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con);
+	con
+
+let get_fd con = Xb.get_fd con.xb
+let close con =
+	Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con);
+	Xb.close con.xb
+
+let get_perm con =
+	con.perm
+
+let restrict con domid =
+	con.perm <- Perms.Connection.restrict con.perm domid
+
+let set_target con target_domid =
+	con.perm <- Perms.Connection.set_target (get_perm con) ~perms:[Perms.READ; Perms.WRITE] target_domid
+
+let send_reply con tid rid ty data =
+	Xb.queue con.xb (Xb.Packet.create tid rid ty data)
+
+let send_error con tid rid err = send_reply con tid rid Xb.Op.Error (err ^ "\000")
+let send_ack con tid rid ty = send_reply con tid rid ty "OK\000"
+
+let get_watch_path con path =
+	if path.[0] = '@' || path.[0] = '/' then
+		path
+	else
+		let rpath = get_path con in
+		rpath ^ path
+
+let get_watches (con: t) path =
+	if Hashtbl.mem con.watches path
+	then Hashtbl.find con.watches path
+	else []
+
+let get_children_watches con path =
+	let path = path ^ "/" in
+	List.concat (Hashtbl.fold (fun p w l ->
+		if String.startswith path p then w :: l else l) con.watches [])
+
+let is_dom0 con =
+	Perms.Connection.is_dom0 (get_perm con)
+
+let add_watch con path token =
+	if !Quota.activate && !Define.maxwatch > 0 &&
+	   not (is_dom0 con) && con.nb_watches > !Define.maxwatch then
+		raise Quota.Limit_reached;
+	let apath = get_watch_path con path in
+	let l = get_watches con apath in
+	if List.exists (fun w -> w.token = token) l then
+		raise Define.Already_exist;
+	let watch = watch_create ~con ~token ~path in
+	Hashtbl.replace con.watches apath (watch :: l);
+	con.nb_watches <- con.nb_watches + 1;
+	apath, watch
+
+let del_watch con path token =
+	let apath = get_watch_path con path in
+	let ws = Hashtbl.find con.watches apath in
+	let w = List.find (fun w -> w.token = token) ws in
+	let filtered = Utils.list_remove w ws in
+	if List.length filtered > 0 then
+		Hashtbl.replace con.watches apath filtered
+	else
+		Hashtbl.remove con.watches apath;
+	con.nb_watches <- con.nb_watches - 1;
+	apath, w
+
+let list_watches con =
+	let ll = Hashtbl.fold 
+		(fun _ watches acc -> List.map (fun watch -> watch.path, watch.token) watches :: acc)
+		con.watches [] in
+	List.concat ll
+
+let fire_single_watch watch =
+	let data = Utils.join_by_null [watch.path; watch.token; ""] in
+	send_reply watch.con Transaction.none 0 Xb.Op.Watchevent data
+
+let fire_watch watch path =
+	let new_path =
+		if watch.is_relative && path.[0] = '/'
+		then begin
+			let n = String.length watch.base
+		 	and m = String.length path in
+			String.sub path n (m - n)
+		end else
+			path
+	in
+	let data = Utils.join_by_null [ new_path; watch.token; "" ] in
+	send_reply watch.con Transaction.none 0 Xb.Op.Watchevent data
+
+let find_next_tid con =
+	let ret = con.next_tid in con.next_tid <- con.next_tid + 1; ret
+
+let start_transaction con store =
+	if !Define.maxtransaction > 0 && not (is_dom0 con)
+	&& Hashtbl.length con.transactions > !Define.maxtransaction then
+		raise Quota.Transaction_opened;
+	let id = find_next_tid con in
+	let ntrans = Transaction.make id store in
+	Hashtbl.add con.transactions id ntrans;
+	Logging.start_transaction ~tid:id ~con:(get_domstr con);
+	id
+
+let end_transaction con tid commit =
+	let trans = Hashtbl.find con.transactions tid in
+	Hashtbl.remove con.transactions tid;
+	Logging.end_transaction ~tid ~con:(get_domstr con);
+	if commit then Transaction.commit ~con:(get_domstr con) trans else true
+
+let get_transaction con tid =
+	Hashtbl.find con.transactions tid
+
+let do_input con = Xb.input con.xb
+let has_input con = Xb.has_in_packet con.xb
+let pop_in con = Xb.get_in_packet con.xb
+let has_more_input con = Xb.has_more_input con.xb
+
+let has_output con = Xb.has_output con.xb
+let has_new_output con = Xb.has_new_output con.xb
+let peek_output con = Xb.peek_output con.xb
+let do_output con = Xb.output con.xb
+
+let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
+
+let mark_symbols con =
+	Hashtbl.iter (fun _ t -> Store.mark_symbols (Transaction.get_store t)) con.transactions
+
+let stats con =
+	Hashtbl.length con.watches, con.stat_nb_ops
+
+let dump con chan =
+	match con.dom with
+	| Some dom -> 
+		let domid = Domain.get_id dom in
+		(* dump domain *)
+		Domain.dump dom chan;
+		(* dump watches *)
+		List.iter (fun (path, token) ->
+			Printf.fprintf chan "watch,%d,%s,%s\n" domid (Utils.hexify path) (Utils.hexify token)
+			) (list_watches con);
+	| None -> ()

tools/ocaml/xenstored/connections.ml

@@ -0,0 +1,167 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@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 debug fmt = Logs.debug "general" fmt
+
+type t = {
+	mutable anonymous: Connection.t list;
+	domains: (int, Connection.t) Hashtbl.t;
+	mutable watches: (string, Connection.watch list) Trie.t;
+}
+
+let create () = { anonymous = []; domains = Hashtbl.create 8; watches = Trie.create () }
+
+let add_anonymous cons fd can_write =
+	let xbcon = Xb.open_fd fd in
+	let con = Connection.create xbcon None in
+	cons.anonymous <- con :: cons.anonymous
+
+let add_domain cons dom =
+	let xbcon = Xb.open_mmap (Domain.get_interface dom) (fun () -> Domain.notify dom) in
+	let con = Connection.create xbcon (Some dom) in
+	Hashtbl.add cons.domains (Domain.get_id dom) con
+
+let select cons =
+	let inset = List.map (fun c -> Connection.get_fd c) cons.anonymous
+	and outset = List.fold_left (fun l c -> if Connection.has_output c
+						then Connection.get_fd c :: l
+						else l) [] cons.anonymous in
+	inset, outset
+
+let find cons fd =
+	List.find (fun c -> Connection.get_fd c = fd) cons.anonymous
+
+let find_domain cons id =
+	Hashtbl.find cons.domains id
+
+let del_watches_of_con con watches =
+	match List.filter (fun w -> Connection.get_con w != con) watches with
+	| [] -> None
+	| ws -> Some ws 
+
+let del_anonymous cons con =
+	try
+		cons.anonymous <- Utils.list_remove con cons.anonymous;
+		cons.watches <- Trie.map (del_watches_of_con con) cons.watches;
+		Connection.close con
+	with exn ->
+		debug "del anonymous %s" (Printexc.to_string exn)
+
+let del_domain cons id =
+	try
+		let con = find_domain cons id in
+		Hashtbl.remove cons.domains id;
+		cons.watches <- Trie.map (del_watches_of_con con) cons.watches;
+		Connection.close con
+	with exn ->
+		debug "del domain %u: %s" id (Printexc.to_string exn)
+
+let iter_domains cons fct =
+	Hashtbl.iter (fun k c -> fct c) cons.domains
+
+let iter_anonymous cons fct =
+	List.iter (fun c -> fct c) (List.rev cons.anonymous)
+
+let iter cons fct =
+	iter_domains cons fct; iter_anonymous cons fct
+
+let has_more_work cons =
+	Hashtbl.fold (fun id con acc ->
+		if Connection.has_more_input con then
+			con :: acc
+		else
+			acc) cons.domains []
+
+let key_of_str path =
+	if path.[0] = '@'
+	then [path]
+	else "" :: Store.Path.to_string_list (Store.Path.of_string path)
+
+let key_of_path path =
+	"" :: Store.Path.to_string_list path
+
+let add_watch cons con path token =
+	let apath, watch = Connection.add_watch con path token in
+	let key = key_of_str apath in
+	let watches =
+ 		if Trie.mem cons.watches key
+ 		then Trie.find cons.watches key
+ 		else []
+	in
+ 	cons.watches <- Trie.set cons.watches key (watch :: watches);
+	watch
+
+let del_watch cons con path token =
+ 	let apath, watch = Connection.del_watch con path token in
+ 	let key = key_of_str apath in
+ 	let watches = Utils.list_remove watch (Trie.find cons.watches key) in
+ 	if watches = [] then
+		cons.watches <- Trie.unset cons.watches key
+ 	else
+		cons.watches <- Trie.set cons.watches key watches;
+ 	watch
+
+(* path is absolute *)
+let fire_watches cons path recurse =
+	let key = key_of_path path in
+	let path = Store.Path.to_string path in
+	let fire_watch _ = function
+		| None         -> ()
+		| Some watches -> List.iter (fun w -> Connection.fire_watch w path) watches
+	in
+	let fire_rec x = function
+		| None         -> ()
+		| Some watches -> 
+			  List.iter (fun w -> Connection.fire_single_watch w) watches
+	in
+	Trie.iter_path fire_watch cons.watches key;
+	if recurse then
+		Trie.iter fire_rec (Trie.sub cons.watches key)
+
+let fire_spec_watches cons specpath =
+	iter cons (fun con ->
+		List.iter (fun w -> Connection.fire_single_watch w) (Connection.get_watches con specpath))
+
+let set_target cons domain target_domain =
+	let con = find_domain cons domain in
+	Connection.set_target con target_domain
+
+let number_of_transactions cons =
+	let res = ref 0 in
+	let aux con = 
+		res := Connection.number_of_transactions con + !res
+	in
+	iter cons aux;
+	!res
+
+let stats cons =
+	let nb_ops_anon = ref 0 
+	and nb_watchs_anon = ref 0
+	and nb_ops_dom = ref 0
+	and nb_watchs_dom = ref 0 in
+	iter_anonymous cons (fun con ->
+		let con_watchs, con_ops = Connection.stats con in
+		nb_ops_anon := !nb_ops_anon + con_ops;
+		nb_watchs_anon := !nb_watchs_anon + con_watchs;
+	);
+	iter_domains cons (fun con ->
+		let con_watchs, con_ops = Connection.stats con in
+		nb_ops_dom := !nb_ops_dom + con_ops;
+		nb_watchs_dom := !nb_watchs_dom + con_watchs;
+	);
+	(List.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon,
+	 Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom)

tools/ocaml/xenstored/define.ml

@@ -0,0 +1,40 @@
+(*
+ * 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 xenstored_major = 1
+let xenstored_minor = 0
+
+let xenstored_proc_kva = "/proc/xen/xsd_kva"
+let xenstored_proc_port = "/proc/xen/xsd_port"
+
+let xs_daemon_socket = "/var/run/xenstored/socket"
+let xs_daemon_socket_ro = "/var/run/xenstored/socket_ro"
+
+let default_config_dir = "/etc/xensource"
+
+let maxwatch = ref (50)
+let maxtransaction = ref (20)
+
+let domid_self = 0x7FF0
+
+exception Not_a_directory of string
+exception Not_a_value of string
+exception Already_exist
+exception Doesnt_exist
+exception Lookup_Doesnt_exist of string
+exception Invalid_path
+exception Permission_denied
+exception Unknown_operation

tools/ocaml/xenstored/disk.ml

@@ -0,0 +1,157 @@
+(*
+ * 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 enable = ref false
+let xs_daemon_database = "/var/run/xenstored/db"
+
+let error = Logs.error "general"
+
+(* unescape utils *)
+exception Bad_escape
+
+let is_digit c = match c with '0' .. '9' -> true | _ -> false
+
+let undec c =
+	match c with
+	| '0' .. '9' -> (Char.code c) - (Char.code '0')
+	| _          -> raise (Failure "undecify")
+
+let unhex c =
+	let c = Char.lowercase c in
+	match c with
+	| '0' .. '9' -> (Char.code c) - (Char.code '0')
+	| 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10
+	| _          -> raise (Failure "unhexify")
+
+let string_unescaped s =
+	let len = String.length s
+	and i = ref 0 in
+	let d = Buffer.create len in
+
+	let read_escape () =
+		incr i;
+		match s.[!i] with
+		| 'n'  -> '\n'
+		| 'r'  -> '\r'
+		| '\\' -> '\\'
+		| '\'' -> '\''
+		| '"'  -> '"'
+		| 't'  -> '\t'
+		| 'b'  -> '\b'
+		| 'x'  ->
+			let v = (unhex s.[!i + 1] * 16) + unhex s.[!i + 2] in
+			i := !i + 2;
+			Char.chr v
+		| c    ->
+			if is_digit c then (
+				let v = (undec s.[!i]) * 100 +
+					(undec s.[!i + 1]) * 10 +
+					(undec s.[!i + 2]) in
+				i := !i + 2;
+				Char.chr v
+			) else
+				raise Bad_escape
+	in
+
+	while !i < len
+	do
+		let c = match s.[!i] with
+		| '\\' -> read_escape ()
+		| c    -> c in
+		Buffer.add_char d c;
+		incr i
+	done;
+	Buffer.contents d
+
+(* file -> lines_of_file *)
+let file_readlines file =
+	let channel = open_in file in
+	let rec input_line_list channel =
+		let line = try input_line channel with End_of_file -> "" in
+		if String.length line > 0 then
+			line :: input_line_list channel
+		else (
+			close_in channel;
+			[]
+		) in
+	input_line_list channel
+
+let rec map_string_list_range l s =
+	match l with
+	| [] -> []
+	| (a,b) :: l -> String.sub s a (b - a) :: map_string_list_range l s
+
+let is_digit c =
+	try ignore (int_of_char c); true with _ -> false
+
+let rec parse_perm s =
+	let len = String.length s in
+	if len = 0 then
+		[]
+	else
+		let i = ref 1 in
+		while !i < len && is_digit s.[!i] do incr i done;
+		let x = String.sub s 0 !i
+		and lx = String.sub s !i len in
+		x :: parse_perm lx
+
+let read store =
+	(* don't let the permission get on our way, full perm ! *)
+	let v = Store.get_ops store Perms.Connection.full_rights in
+
+	(* a line is : path{perm} or path{perm} = value *)
+	let parse_line s =
+		let path, perm, value =
+			let len = String.length s in
+			let si = if String.contains s '=' then
+					String.index s '='
+				else
+					len - 1 in
+			let pi = String.rindex_from s si '{' in
+			let epi = String.index_from s pi '}' in
+
+			if String.contains s '=' then
+				let ss = map_string_list_range [ (0, pi);
+				                                 (pi + 1, epi);
+				                                 (si + 2, len); ] s in
+				(List.nth ss 0, List.nth ss 1, List.nth ss 2)
+			else
+				let ss = map_string_list_range [ (0, pi);
+				                                 (pi + 1, epi);
+				                               ] s in
+				(List.nth ss 0, List.nth ss 1, "")
+			in
+		let path = Store.Path.of_string path in
+		v.Store.write path (string_unescaped value);
+		v.Store.setperms path (Perms.Node.of_strings (parse_perm perm)) in
+	try
+		let lines = file_readlines xs_daemon_database in
+		List.iter (fun s -> parse_line s) lines
+	with exc ->
+		error "caught exn %s" (Printexc.to_string exc)
+
+let write store =
+	if !enable then
+	try
+		let tfile = Printf.sprintf "%s#" xs_daemon_database in
+		let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ]
+		                           0o600 tfile in
+		Store.dump store channel;
+		flush channel;
+		close_out channel;
+		Unix.rename tfile xs_daemon_database
+	with exc ->
+		error "caught exn %s" (Printexc.to_string exc)

tools/ocaml/xenstored/domain.ml

@@ -0,0 +1,62 @@
+(*
+ * 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.
+ *)
+
+open Printf
+
+let debug fmt = Logs.debug "general" fmt
+
+type t =
+{
+	id: Xc.domid;
+	mfn: nativeint;
+	remote_port: int;
+	interface: Mmap.mmap_interface;
+	eventchn: Event.t;
+	mutable port: int;
+}
+
+let get_path dom = "/local/domain/" ^ (sprintf "%u" dom.id)
+let get_id domain = domain.id
+let get_interface d = d.interface
+let get_mfn d = d.mfn
+let get_remote_port d = d.remote_port
+
+let dump d chan =
+	fprintf chan "dom,%d,%nd,%d\n" d.id d.mfn d.port
+
+let notify dom = Event.notify dom.eventchn dom.port; ()
+
+let bind_interdomain dom =
+	dom.port <- Event.bind_interdomain dom.eventchn dom.id dom.remote_port;
+	debug "domain %d bound port %d" dom.id dom.port
+
+
+let close dom =
+	debug "domain %d unbound port %d" dom.id dom.port;
+	Event.unbind dom.eventchn dom.port;
+	Mmap.unmap dom.interface;
+	()
+
+let make id mfn remote_port interface eventchn = {
+	id = id;
+	mfn = mfn;
+	remote_port = remote_port;
+	interface = interface;
+	eventchn = eventchn;
+	port = -1
+}
+
+let is_dom0 d = d.id = 0

tools/ocaml/xenstored/domains.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 domains = {
+	eventchn: Event.t;
+	table: (Xc.domid, Domain.t) Hashtbl.t;
+}
+
+let init eventchn =
+	{ eventchn = eventchn; table = Hashtbl.create 10 }
+let del doms id = Hashtbl.remove doms.table id
+let exist doms id = Hashtbl.mem doms.table id
+let find doms id = Hashtbl.find doms.table id
+let number doms = Hashtbl.length doms.table
+let iter doms fct = Hashtbl.iter (fun _ b -> fct b) doms.table
+
+let cleanup xc doms =
+	let notify = ref false in
+	let dead_dom = ref [] in
+
+	Hashtbl.iter (fun id _ -> if id <> 0 then
+		try
+			let info = Xc.domain_getinfo xc id in
+			if info.Xc.shutdown || info.Xc.dying then (
+				Logs.debug "general" "Domain %u died (dying=%b, shutdown %b -- code %d)"
+				                    id info.Xc.dying info.Xc.shutdown info.Xc.shutdown_code;
+				if info.Xc.dying then
+					dead_dom := id :: !dead_dom
+				else
+					notify := true;
+			)
+		with Xc.Error _ ->
+			Logs.debug "general" "Domain %u died -- no domain info" id;
+			dead_dom := id :: !dead_dom;
+		) doms.table;
+	List.iter (fun id ->
+		let dom = Hashtbl.find doms.table id in
+		Domain.close dom;
+		Hashtbl.remove doms.table id;
+	) !dead_dom;
+	!notify, !dead_dom
+
+let resume doms domid =
+	()
+
+let create xc doms domid mfn port =
+	let interface = Xc.map_foreign_range xc domid (Mmap.getpagesize()) mfn in
+	let dom = Domain.make domid mfn port interface doms.eventchn in
+	Hashtbl.add doms.table domid dom;
+	Domain.bind_interdomain dom;
+	dom
+
+let create0 fake doms =
+	let port, interface =
+		if fake then (
+			0, Xc.with_intf (fun xc -> Xc.map_foreign_range xc 0 (Mmap.getpagesize()) 0n)
+		) else (
+			let port = Utils.read_file_single_integer Define.xenstored_proc_port
+			and fd = Unix.openfile Define.xenstored_proc_kva
+					       [ Unix.O_RDWR ] 0o600 in
+			let interface = Mmap.mmap fd Mmap.RDWR Mmap.SHARED
+						  (Mmap.getpagesize()) 0 in
+			Unix.close fd;
+			port, interface
+		)
+		in
+	let dom = Domain.make 0 Nativeint.zero port interface doms.eventchn in
+	Hashtbl.add doms.table 0 dom;
+	Domain.bind_interdomain dom;
+	Domain.notify dom;
+	dom

tools/ocaml/xenstored/event.ml

@@ -0,0 +1,29 @@
+(*
+ * 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.
+ *)
+
+(**************** high level binding ****************)
+type t = {
+	fd: Unix.file_descr;
+	mutable virq_port: int;
+}
+
+let init () = { fd = Eventchn.init (); virq_port = -1; }
+let bind_virq eventchn = eventchn.virq_port <- Eventchn.bind_virq eventchn.fd
+let bind_interdomain eventchn domid port = Eventchn.bind_interdomain eventchn.fd domid port
+let unbind eventchn port = Eventchn.unbind eventchn.fd port
+let notify eventchn port = Eventchn.notify eventchn.fd port
+let read_port eventchn = Eventchn.read_port eventchn.fd
+let write_port eventchn port = Eventchn.write_port eventchn.fd port

tools/ocaml/xenstored/logging.ml

@@ -0,0 +1,239 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@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.
+ *)
+
+open Stdext
+open Printf
+
+let error fmt = Logs.error "general" fmt
+let info fmt = Logs.info "general" fmt
+let debug fmt = Logs.debug "general" fmt
+
+let access_log_file = ref "/var/log/xenstored-access.log"
+let access_log_nb_files = ref 20
+let access_log_nb_lines = ref 13215
+let activate_access_log = ref true
+
+(* maximal size of the lines in xenstore-acces.log file *)
+let line_size = 180
+
+let log_read_ops = ref false
+let log_transaction_ops = ref false
+let log_special_ops = ref false
+
+type access_type =
+	| Coalesce
+	| Conflict
+	| Commit
+	| Newconn
+	| Endconn
+	| XbOp of Xb.Op.operation
+
+type access =
+	{
+		fd: out_channel ref;
+		counter: int ref;
+		write: tid:int -> con:string -> ?data:string -> access_type -> unit;
+	}
+
+let string_of_date () =
+	let time = Unix.gettimeofday () in
+	let tm = Unix.localtime time in
+	let msec = time -. (floor time) in
+	sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d" (1900 + tm.Unix.tm_year)
+		(tm.Unix.tm_mon + 1)
+		tm.Unix.tm_mday
+		tm.Unix.tm_hour
+		tm.Unix.tm_min
+		tm.Unix.tm_sec
+		(int_of_float (1000.0 *. msec))
+
+let fill_with_space n s =
+	if String.length s < n
+	then 
+		let r = String.make n ' ' in
+		String.blit s 0  r 0 (String.length s);
+		r
+	else 
+		s
+
+let string_of_tid ~con tid =
+	if tid = 0
+	then fill_with_space 12 (sprintf "%s" con)
+	else fill_with_space 12 (sprintf "%s.%i" con tid)
+
+let string_of_access_type = function
+	| Coalesce                -> "coalesce "
+	| Conflict                -> "conflict "
+	| Commit                  -> "commit   "
+	| Newconn                 -> "newconn  "
+	| Endconn                 -> "endconn  "
+
+	| XbOp op -> match op with
+	| Xb.Op.Debug             -> "debug    "
+
+	| Xb.Op.Directory         -> "directory"
+	| Xb.Op.Read              -> "read     "
+	| Xb.Op.Getperms          -> "getperms "
+
+	| Xb.Op.Watch             -> "watch    "
+	| Xb.Op.Unwatch           -> "unwatch  "
+
+	| Xb.Op.Transaction_start -> "t start  "
+	| Xb.Op.Transaction_end   -> "t end    "
+
+	| Xb.Op.Introduce         -> "introduce"
+	| Xb.Op.Release           -> "release  "
+	| Xb.Op.Getdomainpath     -> "getdomain"
+	| Xb.Op.Isintroduced      -> "is introduced"
+	| Xb.Op.Resume            -> "resume   "
+ 
+	| Xb.Op.Write             -> "write    "
+	| Xb.Op.Mkdir             -> "mkdir    "
+	| Xb.Op.Rm                -> "rm       "
+	| Xb.Op.Setperms          -> "setperms "
+	| Xb.Op.Restrict          -> "restrict "
+	| Xb.Op.Set_target        -> "settarget"
+
+	| Xb.Op.Error             -> "error    "
+	| Xb.Op.Watchevent        -> "w event  "
+
+	| x                       -> Xb.Op.to_string x
+
+let file_exists file =
+	try
+		Unix.close (Unix.openfile file [Unix.O_RDONLY] 0o644);
+		true
+	with _ ->
+		false
+
+let log_rotate fd =
+	let file n = sprintf "%s.%i" !access_log_file n in
+	let log_files =
+		let rec aux accu n =
+			if n >= !access_log_nb_files
+			then accu
+			else if n = 1 && file_exists !access_log_file
+			then aux [!access_log_file,1] 2
+			else
+				let file = file (n-1) in
+				if file_exists file
+				then aux ((file,n) :: accu) (n+1)
+				else accu
+		in
+		aux [] 1
+	in
+	let rec rename = function
+		| (f,n) :: t when n < !access_log_nb_files -> 
+			Unix.rename f (file n);
+			rename t
+		| _ -> ()
+	in
+	rename log_files;
+	close_out !fd;
+	fd := open_out !access_log_file
+
+let sanitize_data data =
+	let data = String.copy data in
+	for i = 0 to String.length data - 1
+	do
+		if data.[i] = '\000' then
+			data.[i] <- ' '
+	done;
+	String.escaped data
+
+let make save_to_disk =
+	let fd = ref (open_out_gen [Open_append; Open_creat] 0o644 !access_log_file) in
+	let counter = ref 0 in
+	{
+		fd = fd;
+		counter = counter;
+		write = 
+			if not !activate_access_log || !access_log_nb_files = 0
+			then begin fun ~tid ~con ?data _ -> () end
+			else fun ~tid ~con ?(data="") access_type ->
+				let s = Printf.sprintf "[%s] %s %s %s\n" (string_of_date()) (string_of_tid ~con tid) 
+					(string_of_access_type access_type) (sanitize_data data) in
+				let s =
+					if String.length s > line_size
+					then begin
+						let s = String.sub s 0 line_size in
+						s.[line_size-3] <- '.'; 
+						s.[line_size-2] <- '.';
+						s.[line_size-1] <- '\n';
+						s
+					end else
+						s
+				in
+				incr counter;
+				output_string !fd s;
+				flush !fd;
+				if !counter > !access_log_nb_lines 
+				then begin 
+					log_rotate fd;
+					save_to_disk ();
+					counter := 0;
+				end
+	}
+
+let access : (access option) ref = ref None
+let init aal save_to_disk =
+	activate_access_log := aal;
+	access := Some (make save_to_disk)
+
+let write_access_log ~con ~tid ?data access_type = 
+        try
+	  maybe (fun a -> a.write access_type ~con ~tid ?data) !access
+	with _ -> ()
+
+let new_connection = write_access_log Newconn
+let end_connection = write_access_log Endconn
+let read_coalesce ~tid ~con data =
+	if !log_read_ops
+	then write_access_log Coalesce ~tid ~con ~data:("read "^data)
+let write_coalesce data = write_access_log Coalesce ~data:("write "^data)
+let conflict = write_access_log Conflict
+let commit = write_access_log Commit
+
+let xb_op ~tid ~con ~ty data =
+	let print =
+	match ty with
+		| Xb.Op.Read | Xb.Op.Directory | Xb.Op.Getperms -> !log_read_ops
+		| Xb.Op.Transaction_start | Xb.Op.Transaction_end ->
+			false (* transactions are managed below *)
+		| Xb.Op.Introduce | Xb.Op.Release | Xb.Op.Getdomainpath | Xb.Op.Isintroduced | Xb.Op.Resume ->
+			!log_special_ops
+		| _ -> true
+	in
+		if print 
+		then write_access_log ~tid ~con ~data (XbOp ty)
+
+let start_transaction ~tid ~con = 
+	if !log_transaction_ops && tid <> 0
+	then write_access_log ~tid ~con (XbOp Xb.Op.Transaction_start)
+
+let end_transaction ~tid ~con = 
+	if !log_transaction_ops && tid <> 0
+	then write_access_log ~tid ~con (XbOp Xb.Op.Transaction_end)
+
+let xb_answer ~tid ~con ~ty data =
+	let print = match ty with
+		| Xb.Op.Error when data="ENOENT " -> !log_read_ops
+		| Xb.Op.Error -> !log_special_ops
+		| Xb.Op.Watchevent -> true
+		| _ -> false
+	in
+		if print
+		then write_access_log ~tid ~con ~data (XbOp ty)

tools/ocaml/xenstored/parse_arg.ml

@@ -0,0 +1,68 @@
+(*
+ * 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 config =
+{
+	domain_init: bool;
+	activate_access_log: bool;
+	daemonize: bool;
+	reraise_top_level: bool;
+	config_file: string option;
+	pidfile: string option; (* old xenstored compatibility *)
+	tracefile: string option; (* old xenstored compatibility *)
+	restart: bool;
+	disable_socket: bool;
+}
+
+let do_argv =
+	let pidfile = ref "" and tracefile = ref "" (* old xenstored compatibility *)
+	and domain_init = ref true
+	and activate_access_log = ref true
+	and daemonize = ref true
+	and reraise_top_level = ref false
+	and config_file = ref ""
+	and restart = ref false
+	and disable_socket = ref false in
+
+	let speclist =
+		[ ("--no-domain-init", Arg.Unit (fun () -> domain_init := false),
+		   "to state that xenstored should not initialise dom0");
+		  ("--config-file", Arg.Set_string config_file,
+		   "set an alternative location for the configuration file");
+		  ("--no-fork", Arg.Unit (fun () -> daemonize := false),
+		   "to request that the daemon does not fork");
+		  ("--reraise-top-level", Arg.Unit (fun () -> reraise_top_level := true),
+		   "reraise exceptions caught at the top level");
+		  ("--no-access-log", Arg.Unit (fun () -> activate_access_log := false),
+		  "do not create a xenstore-access.log file");
+		  ("--pid-file", Arg.Set_string pidfile, ""); (* for compatibility *)
+		  ("-T", Arg.Set_string tracefile, ""); (* for compatibility *)
+		  ("--restart", Arg.Set restart, "Read database on starting");
+		  ("--disable-socket", Arg.Unit (fun () -> disable_socket := true), "Disable socket");
+		] in
+	let usage_msg = "usage : xenstored [--config-file <filename>] [--no-domain-init] [--help] [--no-fork] [--reraise-top-level] [--restart] [--disable-socket]" in
+	Arg.parse speclist (fun s -> ()) usage_msg;
+	{
+		domain_init = !domain_init;
+		activate_access_log = !activate_access_log;
+		daemonize = !daemonize;
+		reraise_top_level = !reraise_top_level;
+		config_file = if !config_file <> "" then Some !config_file else None;
+		pidfile = if !pidfile <> "" then Some !pidfile else None;
+		tracefile = if !tracefile <> "" then Some !tracefile else None;
+		restart = !restart;
+		disable_socket = !disable_socket;
+	}

tools/ocaml/xenstored/perms.ml

@@ -0,0 +1,167 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@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.
+ *)
+
+open Stdext
+
+let activate = ref true
+
+type permty = READ | WRITE | RDWR | NONE
+
+let char_of_permty perm =
+	match perm with
+	| READ -> 'r'
+	| WRITE -> 'w'
+	| RDWR -> 'b'
+	| NONE -> 'n'
+
+let permty_of_char c =
+	match c with
+	| 'r' -> READ
+	| 'w' -> WRITE
+	| 'b' -> RDWR
+	| 'n' -> NONE
+	| _ -> invalid_arg "unknown permission type"
+
+
+(* node permissions *)
+module Node =
+struct
+
+type t =
+{
+	owner: Xc.domid;
+	other: permty;
+	acl: (Xc.domid * permty) list;
+}
+
+let create owner other acl =
+	{ owner = owner; other = other; acl = acl }
+
+let get_other perms = perms.other
+let get_acl perms = perms.acl
+let get_owner perm = perm.owner
+
+let default0 = create 0 NONE []
+
+let perm_of_string s =
+	let ty = permty_of_char s.[0]
+	and id = int_of_string (String.sub s 1 (String.length s - 1)) in
+	(id, ty)
+
+let of_strings ls =
+	let vect = List.map (perm_of_string) ls in
+	match vect with
+	| [] -> invalid_arg "permvec empty"
+	| h :: l -> create (fst h) (snd h) l
+
+(* [s] must end with '\000' *)
+let of_string s =
+	let ls = String.split '\000' s in
+	let ls = if ls = [] then ls else List.rev (List.tl (List.rev ls)) in
+	of_strings ls
+
+let string_of_perm perm =
+	Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm)
+
+let to_string permvec =
+	let l = ((permvec.owner, permvec.other) :: permvec.acl) in
+	String.concat "\000" (List.map string_of_perm l)
+
+end
+
+
+(* permission of connections *)
+module Connection =
+struct
+
+type elt = Xc.domid * (permty list)
+type t =
+	{ main: elt;
+	  target: elt option; }
+
+let full_rights : t =
+	{ main = 0, [READ; WRITE];
+	  target = None }
+
+let create ?(perms=[NONE]) domid : t =
+	{ main = (domid, perms);
+	  target = None }
+
+let set_target (connection:t) ?(perms=[NONE]) domid =
+	{ connection with target = Some (domid, perms) }
+
+let get_owners (connection:t) =
+	match connection.main, connection.target with
+	| c1, Some c2 -> [ fst c1; fst c2 ]
+	| c1, None    -> [ fst c1 ]
+
+let is_owner (connection:t) id =
+	match connection.target with
+	| Some target -> fst connection.main = id || fst target = id
+	| None        -> fst connection.main = id
+
+let is_dom0 (connection:t) =
+	is_owner connection 0
+
+let restrict (connection:t) domid =
+	match connection.target, connection.main with
+	| None, (0, perms) -> { connection with main = (domid, perms) }
+	| _                -> raise Define.Permission_denied
+
+let elt_to_string (i,p) =
+	Printf.sprintf "%i%S" i (String.concat "" (List.map String.of_char (List.map char_of_permty p)))
+
+let to_string connection =
+	Printf.sprintf "%s%s" (elt_to_string connection.main) (default "" (may elt_to_string connection.target))
+end
+
+(* check if owner of the current connection and of the current node are the same *)
+let check_owner (connection:Connection.t) (node:Node.t) =
+	if !activate && not (Connection.is_dom0 connection)
+	then Connection.is_owner connection (Node.get_owner node)
+	else true
+
+(* check if the current connection has the requested perm on the current node *)
+let check (connection:Connection.t) request (node:Node.t) =
+	let check_acl domainid =
+		let perm =
+			if List.mem_assoc domainid (Node.get_acl node)
+			then List.assoc domainid (Node.get_acl node)
+			else Node.get_other node
+		in
+		match perm, request with
+		| NONE, _ ->
+			Logs.info "io" "Permission denied: Domain %d has no permission" domainid;
+			false
+		| RDWR, _ -> true
+		| READ, READ -> true
+		| WRITE, WRITE -> true
+		| READ, _ ->
+			Logs.info "io" "Permission denied: Domain %d has read only access" domainid;
+			false
+		| WRITE, _ ->
+			Logs.info "io" "Permission denied: Domain %d has write only access" domainid;
+			false
+	in
+	if !activate
+	&& not (Connection.is_dom0 connection)
+	&& not (check_owner connection node)
+	&& not (List.exists check_acl (Connection.get_owners connection))
+	then raise Define.Permission_denied
+
+let equiv perm1 perm2 =
+	(Node.to_string perm1) = (Node.to_string perm2)

tools/ocaml/xenstored/process.ml

@@ -0,0 +1,396 @@
+(*
+ * 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.
+ *)
+
+open Printf
+open Stdext
+
+exception Transaction_again
+exception Transaction_nested
+exception Domain_not_match
+exception Invalid_Cmd_Args
+
+let allow_debug = ref false
+
+let c_int_of_string s =
+	let v = ref 0 in
+	let is_digit c = c >= '0' && c <= '9' in
+	let len = String.length s in
+	let i = ref 0 in
+	while !i < len && not (is_digit s.[!i]) do incr i done;
+	while !i < len && is_digit s.[!i]
+	do
+		let x = (Char.code s.[!i]) - (Char.code '0') in
+		v := !v * 10 + x;
+		incr i
+	done;
+	!v
+
+(* when we don't want a limit, apply a max limit of 8 arguments.
+   no arguments take more than 3 currently, which is pointless to split
+   more than needed. *)
+let split limit c s =
+	let limit = match limit with None -> 8 | Some x -> x in
+	String.split ~limit c s
+
+let split_one_path data con =
+	let args = split (Some 2) '\000' data in
+	match args with
+	| path :: "" :: [] -> Store.Path.create path (Connection.get_path con)
+	| _                -> raise Invalid_Cmd_Args
+
+let process_watch ops cons =
+	let do_op_watch op cons =
+		let recurse = match (fst op) with
+		| Xb.Op.Write    -> false
+		| Xb.Op.Mkdir    -> false
+		| Xb.Op.Rm       -> true
+		| Xb.Op.Setperms -> false
+		| _              -> raise (Failure "huh ?") in
+		Connections.fire_watches cons (snd op) recurse in
+	List.iter (fun op -> do_op_watch op cons) ops
+
+let create_implicit_path t perm path =
+	let dirname = Store.Path.get_parent path in
+	if not (Transaction.path_exists t dirname) then (
+		let rec check_path p =
+			match p with
+			| []      -> []
+			| h :: l  ->
+				if Transaction.path_exists t h then
+					check_path l
+				else
+					p in
+		let ret = check_path (List.tl (Store.Path.get_hierarchy dirname)) in
+		List.iter (fun s -> Transaction.mkdir ~with_watch:false t perm s) ret
+	)
+
+(* packets *)
+let do_debug con t domains cons data =
+	if not !allow_debug
+	then None
+	else try match split None '\000' data with
+	| "print" :: msg :: _ ->
+		Logging.xb_op ~tid:0 ~ty:Xb.Op.Debug ~con:"=======>" msg;
+		None
+	| "quota" :: domid :: _ ->
+		let domid = int_of_string domid in
+		let quota = (Store.get_quota t.Transaction.store) in
+		Some (Quota.to_string quota domid ^ "\000")
+	| "mfn" :: domid :: _ ->
+		let domid = int_of_string domid in
+		let con = Connections.find_domain cons domid in
+		may (fun dom -> Printf.sprintf "%nd\000" (Domain.get_mfn dom)) (Connection.get_domain con)
+	| _ -> None
+	with _ -> None
+
+let do_directory con t domains cons data =
+	let path = split_one_path data con in
+	let entries = Transaction.ls t (Connection.get_perm con) path in
+	if List.length entries > 0 then
+		(Utils.join_by_null entries) ^ "\000"
+	else
+		""
+
+let do_read con t domains cons data =
+	let path = split_one_path data con in
+	Transaction.read t (Connection.get_perm con) path
+
+let do_getperms con t domains cons data =
+	let path = split_one_path data con in
+	let perms = Transaction.getperms t (Connection.get_perm con) path in
+	Perms.Node.to_string perms ^ "\000"
+
+let do_watch con t rid domains cons data =
+	let (node, token) = 
+		match (split None '\000' data) with
+		| [node; token; ""]   -> node, token
+		| _                   -> raise Invalid_Cmd_Args
+		in
+	let watch = Connections.add_watch cons con node token in
+	Connection.send_ack con (Transaction.get_id t) rid Xb.Op.Watch;
+	Connection.fire_single_watch watch
+
+let do_unwatch con t domains cons data =
+	let (node, token) =
+		match (split None '\000' data) with
+		| [node; token; ""]   -> node, token
+		| _                   -> raise Invalid_Cmd_Args
+		in
+	Connections.del_watch cons con node token
+
+let do_transaction_start con t domains cons data =
+	if Transaction.get_id t <> Transaction.none then
+		raise Transaction_nested;
+	let store = Transaction.get_store t in
+	string_of_int (Connection.start_transaction con store) ^ "\000"
+
+let do_transaction_end con t domains cons data =
+	let commit =
+		match (split None '\000' data) with
+		| "T" :: _ -> true
+		| "F" :: _ -> false
+		| x :: _   -> raise (Invalid_argument x)
+		| _        -> raise Invalid_Cmd_Args
+		in
+	let success =
+		Connection.end_transaction con (Transaction.get_id t) commit in
+	if not success then
+		raise Transaction_again;
+	if commit then
+		process_watch (List.rev (Transaction.get_ops t)) cons
+
+let do_introduce con t domains cons data =
+	if not (Connection.is_dom0 con)
+	then raise Define.Permission_denied;
+	let (domid, mfn, port) =
+		match (split None '\000' data) with
+		| domid :: mfn :: port :: _ ->
+			int_of_string domid, Nativeint.of_string mfn, int_of_string port
+		| _                         -> raise Invalid_Cmd_Args;
+		in
+	let dom =
+		if Domains.exist domains domid then
+			Domains.find domains domid
+		else try
+			let ndom = Xc.with_intf (fun xc ->
+				Domains.create xc domains domid mfn port) in
+			Connections.add_domain cons ndom;
+			Connections.fire_spec_watches cons "@introduceDomain";
+			ndom
+		with _ -> raise Invalid_Cmd_Args
+	in
+	if (Domain.get_remote_port dom) <> port || (Domain.get_mfn dom) <> mfn then
+		raise Domain_not_match
+
+let do_release con t domains cons data =
+	if not (Connection.is_dom0 con)
+	then raise Define.Permission_denied;
+	let domid =
+		match (split None '\000' data) with
+		| [domid;""] -> int_of_string domid
+		| _          -> raise Invalid_Cmd_Args
+		in
+	let fire_spec_watches = Domains.exist domains domid in
+	Domains.del domains domid;
+	Connections.del_domain cons domid;
+	if fire_spec_watches 
+	then Connections.fire_spec_watches cons "@releaseDomain"
+	else raise Invalid_Cmd_Args
+
+let do_resume con t domains cons data =
+	if not (Connection.is_dom0 con)
+	then raise Define.Permission_denied;
+	let domid =
+		match (split None '\000' data) with
+		| domid :: _ -> int_of_string domid
+		| _          -> raise Invalid_Cmd_Args
+		in
+	if Domains.exist domains domid
+	then Domains.resume domains domid
+	else raise Invalid_Cmd_Args
+
+let do_getdomainpath con t domains cons data =
+	let domid =
+		match (split None '\000' data) with
+		| domid :: "" :: [] -> c_int_of_string domid
+		| _                 -> raise Invalid_Cmd_Args
+		in
+	sprintf "/local/domain/%u\000" domid
+
+let do_write con t domains cons data =
+	let path, value =
+		match (split (Some 2) '\000' data) with
+		| path :: value :: [] -> Store.Path.create path (Connection.get_path con), value
+		| _                   -> raise Invalid_Cmd_Args
+		in
+	create_implicit_path t (Connection.get_perm con) path;
+	Transaction.write t (Connection.get_perm con) path value
+
+let do_mkdir con t domains cons data =
+	let path = split_one_path data con in
+	create_implicit_path t (Connection.get_perm con) path;
+	try
+		Transaction.mkdir t (Connection.get_perm con) path
+	with
+		Define.Already_exist -> ()
+
+let do_rm con t domains cons data =
+	let path = split_one_path data con in
+	try
+		Transaction.rm t (Connection.get_perm con) path
+	with
+		Define.Doesnt_exist -> ()
+
+let do_setperms con t domains cons data =
+	let path, perms =
+		match (split (Some 2) '\000' data) with
+		| path :: perms :: _ ->
+			Store.Path.create path (Connection.get_path con),
+			(Perms.Node.of_string perms)
+		| _                   -> raise Invalid_Cmd_Args
+		in
+	Transaction.setperms t (Connection.get_perm con) path perms
+
+let do_error con t domains cons data =
+	raise Define.Unknown_operation
+
+let do_isintroduced con t domains cons data =
+	let domid =
+		match (split None '\000' data) with
+		| domid :: _ -> int_of_string domid
+		| _          -> raise Invalid_Cmd_Args
+		in
+	if domid = Define.domid_self || Domains.exist domains domid then "T\000" else "F\000"
+
+(* [restrict] is in the patch queue since xen3.2 *)
+let do_restrict con t domains cons data =
+	if not (Connection.is_dom0 con)
+	then raise Define.Permission_denied;
+	let domid =
+		match (split None '\000' data) with
+		| [ domid; "" ] -> c_int_of_string domid
+		| _          -> raise Invalid_Cmd_Args
+	in
+	Connection.restrict con domid
+
+(* only in >= xen3.3                                                                                    *)
+(* we ensure backward compatibility with restrict by counting the number of argument of set_target ...  *)
+(* This is not very elegant, but it is safe as 'restrict' only restricts permission of dom0 connections *)
+let do_set_target con t domains cons data =
+	if not (Connection.is_dom0 con)
+	then raise Define.Permission_denied;
+	match split None '\000' data with
+		| [ domid; "" ]               -> do_restrict con t domains con data (* backward compatibility with xen3.2-pq *)
+		| [ domid; target_domid; "" ] -> Connections.set_target cons (c_int_of_string domid) (c_int_of_string target_domid)
+		| _                           -> raise Invalid_Cmd_Args
+
+(*------------- Generic handling of ty ------------------*)
+let reply_ack fct ty con t rid doms cons data =
+	fct con t doms cons data;
+	Connection.send_ack con (Transaction.get_id t) rid ty;
+	if Transaction.get_id t = Transaction.none then
+		process_watch (Transaction.get_ops t) cons
+
+let reply_data fct ty con t rid doms cons data =
+	let ret = fct con t doms cons data in
+	Connection.send_reply con (Transaction.get_id t) rid ty ret
+
+let reply_data_or_ack fct ty con t rid doms cons data =
+	match fct con t doms cons data with
+		| Some ret -> Connection.send_reply con (Transaction.get_id t) rid ty ret
+		| None -> Connection.send_ack con (Transaction.get_id t) rid ty
+
+let reply_none fct ty con t rid doms cons data =
+	(* let the function reply *)
+	fct con t rid doms cons data
+
+let function_of_type ty =
+	match ty with
+	| Xb.Op.Debug             -> reply_data_or_ack do_debug
+	| Xb.Op.Directory         -> reply_data do_directory
+	| Xb.Op.Read              -> reply_data do_read
+	| Xb.Op.Getperms          -> reply_data do_getperms
+	| Xb.Op.Watch             -> reply_none do_watch
+	| Xb.Op.Unwatch           -> reply_ack do_unwatch
+	| Xb.Op.Transaction_start -> reply_data do_transaction_start
+	| Xb.Op.Transaction_end   -> reply_ack do_transaction_end
+	| Xb.Op.Introduce         -> reply_ack do_introduce
+	| Xb.Op.Release           -> reply_ack do_release
+	| Xb.Op.Getdomainpath     -> reply_data do_getdomainpath
+	| Xb.Op.Write             -> reply_ack do_write
+	| Xb.Op.Mkdir             -> reply_ack do_mkdir
+	| Xb.Op.Rm                -> reply_ack do_rm
+	| Xb.Op.Setperms          -> reply_ack do_setperms
+	| Xb.Op.Isintroduced      -> reply_data do_isintroduced
+	| Xb.Op.Resume            -> reply_ack do_resume
+	| Xb.Op.Set_target        -> reply_ack do_set_target
+	| Xb.Op.Restrict          -> reply_ack do_restrict
+	| _                       -> reply_ack do_error
+
+let input_handle_error ~cons ~doms ~fct ~ty ~con ~t ~rid ~data =
+	let reply_error e =
+		Connection.send_error con (Transaction.get_id t) rid e in
+	try
+		fct ty con t rid doms cons data
+	with
+	| Define.Invalid_path          -> reply_error "EINVAL"
+	| Define.Already_exist         -> reply_error "EEXIST"
+	| Define.Doesnt_exist          -> reply_error "ENOENT"
+	| Define.Lookup_Doesnt_exist s -> reply_error "ENOENT"
+	| Define.Permission_denied     -> reply_error "EACCES"
+	| Not_found                    -> reply_error "ENOENT"
+	| Invalid_Cmd_Args             -> reply_error "EINVAL"
+	| Invalid_argument i           -> reply_error "EINVAL"
+	| Transaction_again            -> reply_error "EAGAIN"
+	| Transaction_nested           -> reply_error "EBUSY"
+	| Domain_not_match             -> reply_error "EINVAL"
+	| Quota.Limit_reached          -> reply_error "EQUOTA"
+	| Quota.Data_too_big           -> reply_error "E2BIG"
+	| Quota.Transaction_opened     -> reply_error "EQUOTA"
+	| (Failure "int_of_string")    -> reply_error "EINVAL"
+	| Define.Unknown_operation     -> reply_error "ENOSYS"
+
+(**
+ * Nothrow guarantee.
+ *)
+let process_packet ~store ~cons ~doms ~con ~tid ~rid ~ty ~data =
+	try
+		let fct = function_of_type ty in
+		let t =
+			if tid = Transaction.none then
+				Transaction.make tid store
+			else
+				Connection.get_transaction con tid
+			in
+		input_handle_error ~cons ~doms ~fct ~ty ~con ~t ~rid ~data;
+	with exn ->
+		Logs.error "general" "process packet: %s"
+		          (Printexc.to_string exn);
+		Connection.send_error con tid rid "EIO"
+
+let write_access_log ~ty ~tid ~con ~data =
+	Logging.xb_op ~ty ~tid ~con:(Connection.get_domstr con) data
+
+let write_answer_log ~ty ~tid ~con ~data =
+	Logging.xb_answer ~ty ~tid ~con:(Connection.get_domstr con) data
+
+let do_input store cons doms con =
+	if Connection.do_input con then (
+		let packet = Connection.pop_in con in
+		let tid, rid, ty, data = Xb.Packet.unpack packet in
+		(* As we don't log IO, do not call an unnecessary sanitize_data 
+		   Logs.info "io" "[%s] -> [%d] %s \"%s\""
+		         (Connection.get_domstr con) tid
+		         (Xb.Op.to_string ty) (sanitize_data data); *)
+		process_packet ~store ~cons ~doms ~con ~tid ~rid ~ty ~data;
+		write_access_log ~ty ~tid ~con ~data;
+		Connection.incr_ops con;
+	)
+
+let do_output store cons doms con =
+	if Connection.has_output con then (
+		if Connection.has_new_output con then (
+			let packet = Connection.peek_output con in
+			let tid, rid, ty, data = Xb.Packet.unpack packet in
+			(* As we don't log IO, do not call an unnecessary sanitize_data 
+			   Logs.info "io" "[%s] <- %s \"%s\""
+			         (Connection.get_domstr con)
+			         (Xb.Op.to_string ty) (sanitize_data data);*)
+			write_answer_log ~ty ~tid ~con ~data;
+		);
+		ignore (Connection.do_output con)
+	)
+

tools/ocaml/xenstored/quota.ml

@@ -0,0 +1,83 @@
+(*
+ * 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 Limit_reached
+exception Data_too_big
+exception Transaction_opened
+
+let warn fmt = Logs.warn "general" fmt
+let activate = ref true
+let maxent = ref (10000)
+let maxsize = ref (4096)
+
+type t = {
+	maxent: int;               (* max entities per domU *)
+	maxsize: int;              (* max size of data store in one node *)
+	cur: (Xc.domid, int) Hashtbl.t; (* current domains quota *)
+}
+
+let to_string quota domid =
+	if Hashtbl.mem quota.cur domid
+	then Printf.sprintf "dom%i quota: %i/%i" domid (Hashtbl.find quota.cur domid) quota.maxent
+	else Printf.sprintf "dom%i quota: not set" domid
+
+let create () =
+	{ maxent = !maxent; maxsize = !maxsize; cur = Hashtbl.create 100; }
+
+let copy quota = { quota with cur = (Hashtbl.copy quota.cur) }
+
+let del quota id = Hashtbl.remove quota.cur id
+
+let _check quota id size =
+	if size > quota.maxsize then (
+		warn "domain %u err create entry: data too big %d" id size;
+		raise Data_too_big
+	);
+	if id > 0 && Hashtbl.mem quota.cur id then
+		let entry = Hashtbl.find quota.cur id in
+		if entry >= quota.maxent then (
+			warn "domain %u cannot create entry: quota reached" id;
+			raise Limit_reached
+		)
+
+let check quota id size =
+	if !activate then
+		_check quota id size
+
+let get_entry quota id = Hashtbl.find quota.cur id
+
+let set_entry quota id nb =
+	if nb = 0
+	then Hashtbl.remove quota.cur id
+	else begin
+	if Hashtbl.mem quota.cur id then
+		Hashtbl.replace quota.cur id nb
+	else
+		Hashtbl.add quota.cur id nb
+	end
+
+let del_entry quota id =
+	try
+		let nb = get_entry quota id in
+		set_entry quota id (nb - 1)
+	with Not_found -> ()
+
+let add_entry quota id =
+	let nb = try get_entry quota id with Not_found -> 0 in
+	set_entry quota id (nb + 1)
+
+let add quota diff =
+	Hashtbl.iter (fun id nb -> set_entry quota id (get_entry quota id + nb)) diff.cur

tools/ocaml/xenstored/store.ml

@@ -0,0 +1,461 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@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.
+ *)
+open Stdext
+
+module Node = struct
+
+type t = {
+	name: Symbol.t;
+	perms: Perms.Node.t;
+	value: string;
+	children: t list;
+}
+
+let create _name _perms _value =
+	{ name = Symbol.of_string _name; perms = _perms; value = _value; children = []; }
+
+let get_owner node = Perms.Node.get_owner node.perms
+let get_children node = node.children
+let get_value node = node.value
+let get_perms node = node.perms
+let get_name node = Symbol.to_string node.name
+
+let set_value node nvalue = 
+	if node.value = nvalue
+	then node
+	else { node with value = nvalue }
+
+let set_perms node nperms = { node with perms = nperms }
+
+let add_child node child =
+	{ node with children = child :: node.children }
+
+let exists node childname =
+	let childname = Symbol.of_string childname in
+	List.exists (fun n -> n.name = childname) node.children
+
+let find node childname =
+	let childname = Symbol.of_string childname in
+	List.find (fun n -> n.name = childname) node.children
+
+let replace_child node child nchild =
+	(* this is the on-steroid version of the filter one-replace one *)
+	let rec replace_one_in_list l =
+		match l with
+		| []                               -> []
+		| h :: tl when h.name = child.name -> nchild :: tl
+		| h :: tl                          -> h :: replace_one_in_list tl
+		in
+	{ node with children = (replace_one_in_list node.children) }
+
+let del_childname node childname =
+	let sym = Symbol.of_string childname in
+	let rec delete_one_in_list l =
+		match l with
+		| []                        -> raise Not_found
+		| h :: tl when h.name = sym -> tl
+		| h :: tl                   -> h :: delete_one_in_list tl
+		in
+	{ node with children = (delete_one_in_list node.children) }
+
+let del_all_children node =
+	{ node with children = [] }
+
+(* check if the current node can be accessed by the current connection with rperm permissions *)
+let check_perm node connection request =
+	Perms.check connection request node.perms
+
+(* check if the current node is owned by the current connection *)
+let check_owner node connection =
+	if not (Perms.check_owner connection node.perms)
+	then begin
+		Logs.info "io" "Permission denied: Domain %d not owner" (get_owner node);
+		raise Define.Permission_denied;
+	end
+
+let rec recurse fct node = fct node; List.iter (recurse fct) node.children
+
+let unpack node = (Symbol.to_string node.name, node.perms, node.value)
+
+end
+
+module Path = struct
+
+(* represent a path in a store.
+ * [] -> "/"
+ * [ "local"; "domain"; "1" ] -> "/local/domain/1"
+ *)
+type t = string list
+
+let char_is_valid c =
+	(c >= 'a' && c <= 'z') ||
+	(c >= 'A' && c <= 'Z') ||
+	(c >= '0' && c <= '9') ||
+	c = '_' || c = '-' || c = '@'
+
+let name_is_valid name =
+	name <> "" && String.fold_left (fun accu c -> accu && char_is_valid c) true name
+
+let is_valid path =
+	List.for_all name_is_valid path
+
+let of_string s =
+	if s.[0] = '@'
+	then [s]
+	else if s = "/"
+	then []
+	else match String.split '/' s with
+		| "" :: path when is_valid path -> path
+		| _ -> raise Define.Invalid_path
+
+let create path connection_path =
+	of_string (Utils.path_validate path connection_path)
+
+let to_string t =
+	"/" ^ (String.concat "/" t)
+
+let to_string_list x = x
+
+let get_parent t =
+	if t = [] then [] else List.rev (List.tl (List.rev t))
+
+let get_hierarchy path =
+	Utils.get_hierarchy path
+
+let get_common_prefix p1 p2 =
+	let rec compare l1 l2 =
+		match l1, l2 with
+		| h1 :: tl1, h2 :: tl2 ->
+			if h1 = h2 then h1 :: (compare tl1 tl2) else []
+		| _, [] | [], _ ->
+			(* if l1 or l2 is empty, we found the equal part already *)
+			[]
+		in
+	compare p1 p2
+
+let rec lookup_modify node path fct =
+	match path with
+	| []      -> raise (Define.Invalid_path)
+	| h :: [] -> fct node h
+	| h :: l  ->
+		let (n, c) =
+			if not (Node.exists node h) then
+				raise (Define.Lookup_Doesnt_exist h)
+			else
+				(node, Node.find node h) in
+		let nc = lookup_modify c l fct in
+		Node.replace_child n c nc
+
+let apply_modify rnode path fct =
+	lookup_modify rnode path fct
+
+let rec lookup_get node path =
+	match path with
+	| []      -> raise (Define.Invalid_path)
+	| h :: [] ->
+		(try
+			Node.find node h
+		with Not_found ->
+			raise Define.Doesnt_exist)
+	| h :: l  -> let cnode = Node.find node h in lookup_get cnode l
+
+let get_node rnode path =
+	if path = [] then
+		Some rnode
+	else (
+		try Some (lookup_get rnode path) with Define.Doesnt_exist -> None
+	)
+
+(* get the deepest existing node for this path *)
+let rec get_deepest_existing_node node = function
+	| [] -> node
+	| h :: t ->
+		try get_deepest_existing_node (Node.find node h) t 
+		with Not_found -> node
+
+let set_node rnode path nnode =
+	let quota = Quota.create () in
+	if !Quota.activate then Node.recurse (fun node -> Quota.add_entry quota (Node.get_owner node)) nnode;
+	if path = [] then
+		nnode, quota
+	else
+		let set_node node name =
+			try
+				let ent = Node.find node name in
+				if !Quota.activate then Node.recurse (fun node -> Quota.del_entry quota (Node.get_owner node)) ent;
+				Node.replace_child node ent nnode
+			with Not_found ->
+				Node.add_child node nnode
+			in
+		apply_modify rnode path set_node, quota
+
+(* read | ls | getperms use this *)
+let rec lookup node path fct =
+	match path with
+	| []      -> raise (Define.Invalid_path)
+	| h :: [] -> fct node h
+	| h :: l  -> let cnode = Node.find node h in lookup cnode l fct
+
+let apply rnode path fct =
+	lookup rnode path fct
+end
+
+type t =
+{
+	mutable stat_transaction_coalesce: int;
+	mutable stat_transaction_abort: int;
+	mutable root: Node.t;
+	mutable quota: Quota.t;
+}
+
+let get_root store = store.root
+let set_root store root = store.root <- root
+
+let get_quota store = store.quota
+let set_quota store quota = store.quota <- quota
+
+(* modifying functions *)
+let path_mkdir store perm path =
+	let do_mkdir node name =
+		try
+			let ent = Node.find node name in
+			Node.check_perm ent perm Perms.WRITE;
+			raise Define.Already_exist
+		with Not_found ->
+			Node.check_perm node perm Perms.WRITE;
+			Node.add_child node (Node.create name node.Node.perms "") in
+	if path = [] then
+		store.root
+	else
+		Path.apply_modify store.root path do_mkdir
+
+let path_write store perm path value =
+	let node_created = ref false in
+	let do_write node name =
+		try
+			let ent = Node.find node name in
+			Node.check_perm ent perm Perms.WRITE;
+			let nent = Node.set_value ent value in
+			Node.replace_child node ent nent
+		with Not_found ->
+			node_created := true;
+			Node.check_perm node perm Perms.WRITE;
+			Node.add_child node (Node.create name node.Node.perms value) in
+	if path = [] then (
+		Node.check_perm store.root perm Perms.WRITE;
+		Node.set_value store.root value, false
+	) else
+		Path.apply_modify store.root path do_write, !node_created
+
+let path_rm store perm path =
+	let do_rm node name =
+		try
+			let ent = Node.find node name in
+			Node.check_perm ent perm Perms.WRITE;
+			Node.del_childname node name
+		with Not_found ->
+			raise Define.Doesnt_exist in
+	if path = [] then
+		Node.del_all_children store.root
+	else
+		Path.apply_modify store.root path do_rm
+
+let path_setperms store perm path perms =
+	if path = [] then
+		Node.set_perms store.root perms
+	else
+		let do_setperms node name =
+			let c = Node.find node name in
+			Node.check_owner c perm;
+			Node.check_perm c perm Perms.WRITE;
+			let nc = Node.set_perms c perms in
+			Node.replace_child node c nc
+		in
+		Path.apply_modify store.root path do_setperms
+
+(* accessing functions *)
+let get_node store path =
+	Path.get_node store.root path
+
+let get_deepest_existing_node store path =
+	Path.get_deepest_existing_node store.root path
+
+let read store perm path =
+	let do_read node name =
+		let ent = Node.find node name in
+		Node.check_perm ent perm Perms.READ;
+		ent.Node.value
+	in
+	Path.apply store.root path do_read
+
+let ls store perm path =
+	let children =
+		if path = [] then
+			(Node.get_children store.root)
+		else
+			let do_ls node name =
+				let cnode = Node.find node name in
+				Node.check_perm cnode perm Perms.READ;
+				cnode.Node.children in
+			Path.apply store.root path do_ls in
+	List.rev (List.map (fun n -> Symbol.to_string n.Node.name) children)
+
+let getperms store perm path =
+	if path = [] then
+		(Node.get_perms store.root)
+	else
+		let fct n name =
+			let c = Node.find n name in
+			Node.check_perm c perm Perms.READ;
+			c.Node.perms in
+		Path.apply store.root path fct
+
+let path_exists store path =
+	if path = [] then
+		true
+	else
+		try
+			let check_exist node name =
+				ignore(Node.find node name);
+				true in
+			Path.apply store.root path check_exist
+		with Not_found -> false
+
+
+(* others utils *)
+let traversal root_node f =
+	let rec _traversal path node =
+		f path node;
+		List.iter (_traversal (path @ [ Symbol.to_string node.Node.name ])) node.Node.children
+		in
+	_traversal [] root_node
+		
+let dump_store_buf root_node =
+	let buf = Buffer.create 8192 in
+	let dump_node path node =
+		let pathstr = String.concat "/" path in
+		Printf.bprintf buf "%s/%s{%s}" pathstr (Symbol.to_string node.Node.name)
+		               (String.escaped (Perms.Node.to_string (Node.get_perms node)));
+		if String.length node.Node.value > 0 then
+			Printf.bprintf buf " = %s\n" (String.escaped node.Node.value)
+		else
+			Printf.bprintf buf "\n";
+		in
+	traversal root_node dump_node;
+	buf
+
+let dump_store chan root_node =
+	let buf = dump_store_buf root_node in
+	output_string chan (Buffer.contents buf);
+	Buffer.reset buf
+
+let dump_fct store f = traversal store.root f
+let dump store out_chan = dump_store out_chan store.root
+let dump_stdout store = dump_store stdout store.root
+let dump_buffer store = dump_store_buf store.root
+
+
+(* modifying functions with quota udpate *)
+let set_node store path node =
+	let root, quota_diff = Path.set_node store.root path node in
+	store.root <- root;
+	Quota.add store.quota quota_diff
+
+let write store perm path value =
+	let owner = Node.get_owner (get_deepest_existing_node store path) in
+	Quota.check store.quota owner (String.length value);
+	let root, node_created = path_write store perm path value in
+	store.root <- root;
+	if node_created
+	then Quota.add_entry store.quota owner
+
+let mkdir store perm path =
+	let owner = Node.get_owner (get_deepest_existing_node store path) in
+	Quota.check store.quota owner 0;
+	store.root <- path_mkdir store perm path;
+	Quota.add_entry store.quota owner
+
+let rm store perm path =
+	let rmed_node = Path.get_node store.root path in
+	match rmed_node with
+	| None -> raise Define.Doesnt_exist
+	| Some rmed_node ->
+		store.root <- path_rm store perm path;
+		Node.recurse (fun node -> Quota.del_entry store.quota (Node.get_owner node)) rmed_node
+
+let setperms store perm path nperms =
+	match Path.get_node store.root path with
+	| None -> raise Define.Doesnt_exist
+	| Some node ->
+		let old_owner = Node.get_owner node in
+		let new_owner = Perms.Node.get_owner nperms in
+		Quota.check store.quota new_owner 0;
+		store.root <- path_setperms store perm path nperms;
+		Quota.del_entry store.quota old_owner;
+		Quota.add_entry store.quota new_owner
+
+type ops = {
+	store: t;
+	write: Path.t -> string -> unit;
+	mkdir: Path.t -> unit;
+	rm: Path.t -> unit;
+	setperms: Path.t -> Perms.Node.t -> unit;
+	ls: Path.t -> string list;
+	read: Path.t -> string;
+	getperms: Path.t -> Perms.Node.t;
+	path_exists: Path.t -> bool;
+}
+
+let get_ops store perms = {
+	store = store;
+	write = write store perms;
+	mkdir = mkdir store perms;
+	rm = rm store perms;
+	setperms = setperms store perms;
+	ls = ls store perms;
+	read = read store perms;
+	getperms = getperms store perms;
+	path_exists = path_exists store;
+}
+
+let create () = {
+	stat_transaction_coalesce = 0;
+	stat_transaction_abort = 0;
+	root = Node.create "" Perms.Node.default0 "";
+	quota = Quota.create ();
+}
+let copy store = {
+	stat_transaction_coalesce = store.stat_transaction_coalesce;
+	stat_transaction_abort = store.stat_transaction_abort;
+	root = store.root;
+	quota = Quota.copy store.quota;
+}
+
+let mark_symbols store =
+	Node.recurse (fun node -> Symbol.mark_as_used node.Node.name) store.root
+
+let incr_transaction_coalesce store =
+	store.stat_transaction_coalesce <- store.stat_transaction_coalesce + 1
+let incr_transaction_abort store =
+	store.stat_transaction_abort <- store.stat_transaction_abort + 1
+
+let stats store =
+	let nb_nodes = ref 0 in
+	traversal store.root (fun path node ->
+		incr nb_nodes
+	);
+	!nb_nodes, store.stat_transaction_abort, store.stat_transaction_coalesce

tools/ocaml/xenstored/symbol.ml

@@ -0,0 +1,76 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@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 = int
+
+type 'a record = { data: 'a; mutable garbage: bool }
+let int_string_tbl : (int,string record) Hashtbl.t = Hashtbl.create 1024
+let string_int_tbl : (string,int) Hashtbl.t = Hashtbl.create 1024
+
+let created_counter = ref 0
+let used_counter = ref 0
+
+let count = ref 0
+let rec fresh () =
+	if Hashtbl.mem int_string_tbl !count
+	then begin
+		incr count;
+		fresh ()
+	end else
+		!count
+
+let new_record v = { data=v; garbage=false }
+
+let of_string name =
+	if Hashtbl.mem string_int_tbl name
+	then begin
+		incr used_counter;
+		Hashtbl.find string_int_tbl name
+	end else begin
+		let i = fresh () in
+		incr created_counter;
+		Hashtbl.add string_int_tbl name i;
+		Hashtbl.add int_string_tbl i (new_record name);
+		i
+	end
+
+let to_string i =
+	(Hashtbl.find int_string_tbl i).data
+
+let mark_all_as_unused () =
+	Hashtbl.iter (fun _ v -> v.garbage <- true) int_string_tbl
+
+let mark_as_used symb =
+	let record1 = Hashtbl.find int_string_tbl symb in
+		record1.garbage <- false
+
+let garbage () =
+	let records = Hashtbl.fold (fun symb record accu ->
+		if record.garbage then (symb, record.data) :: accu else accu
+	) int_string_tbl [] in
+	let remove (int,string) =
+		Hashtbl.remove int_string_tbl int;
+		Hashtbl.remove string_int_tbl string
+	in
+	created_counter := 0;
+	used_counter := 0;
+	List.iter remove records
+
+let stats () =
+	Hashtbl.length string_int_tbl
+
+let created () = !created_counter
+let used () = !used_counter

tools/ocaml/xenstored/symbol.mli

@@ -0,0 +1,52 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@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.
+ *)
+
+(** Node names *)
+
+(** Xenstore nodes names are often the same, ie. "local", "domain", "device", ... so it is worth to 
+    manipulate them through the use of small identifiers that we call symbols. These symbols can be 
+    compared in constant time (as opposite to strings) and should help the ocaml GC. *)
+
+type t
+(** The type of symbols. *)
+
+val of_string : string -> t
+(** Convert a string into a symbol. *)
+
+val to_string : t -> string
+(** Convert a symbol into a string. *)
+
+(** {6 Garbage Collection} *)
+
+(** Symbols need to be regulary garbage collected. The following steps should be followed:
+-     mark all the knowns symbols as unused (with [mark_all_as_unused]);
+-     mark all the symbols really usefull as used (with [mark_as_used]); and
+-     finally, call [garbage] *)
+
+val mark_all_as_unused : unit -> unit
+val mark_as_used : t -> unit
+val garbage : unit -> unit
+
+(** {6 Statistics } *)
+
+val stats : unit -> int
+(** Get the number of used symbols. *)
+
+val created : unit -> int
+(** Returns the number of symbols created since the last GC. *)
+
+val used : unit -> int
+(** Returns the number of existing symbols used since the last GC *)

tools/ocaml/xenstored/transaction.ml

@@ -0,0 +1,198 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@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.
+ *)
+open Stdext
+
+let none = 0
+let test_eagain = ref false
+let do_coalesce = ref true
+
+let check_parents_perms_identical root1 root2 path =
+	let hierarch = Store.Path.get_hierarchy path in
+	let permdiff = List.fold_left (fun acc path ->
+		let n1 = Store.Path.get_node root1 path
+		and n2 = Store.Path.get_node root2 path in
+		match n1, n2 with
+		| Some n1, Some n2 ->
+			not (Perms.equiv (Store.Node.get_perms n1) (Store.Node.get_perms n2)) || acc
+		| _ ->
+			true || acc
+	) false hierarch in
+	(not permdiff)
+
+let get_lowest path1 path2 =
+	match path2 with
+	| None       -> Some path1
+	| Some path2 -> Some (Store.Path.get_common_prefix path1 path2)
+
+let test_coalesce oldroot currentroot optpath =
+	match optpath with
+	| None      -> true
+	| Some path ->
+		let oldnode = Store.Path.get_node oldroot path
+		and currentnode = Store.Path.get_node currentroot path in
+		
+		match oldnode, currentnode with
+		| (Some oldnode), (Some currentnode) ->
+			if oldnode == currentnode then (
+				check_parents_perms_identical oldroot currentroot path
+			) else (
+				false
+			)
+		| None, None -> (
+			(* ok then it doesn't exists in the old version and the current version,
+			   just sneak it in as a child of the parent node if it exists, or else fail *)
+			let pnode = Store.Path.get_node currentroot (Store.Path.get_parent path) in
+			match pnode with
+			| None       -> false (* ok it doesn't exists, just bail out. *)
+			| Some pnode -> true
+			)
+		| _ ->
+			false
+
+let can_coalesce oldroot currentroot path =
+	if !do_coalesce then
+		try test_coalesce oldroot currentroot path with _ -> false
+	else
+		false
+
+type ty = No | Full of (int * Store.Node.t * Store.t)
+
+type t = {
+	ty: ty;
+	store: Store.t;
+	mutable ops: (Xb.Op.operation * Store.Path.t) list;
+	mutable read_lowpath: Store.Path.t option;
+	mutable write_lowpath: Store.Path.t option;
+}
+
+let make id store =
+	let ty = if id = none then No else Full(id, Store.get_root store, store) in
+	{
+		ty = ty;
+		store = if id = none then store else Store.copy store;
+		ops = [];
+		read_lowpath = None;
+		write_lowpath = None;
+	}
+
+let get_id t = match t.ty with No -> none | Full (id, _, _) -> id
+let get_store t = t.store
+let get_ops t = t.ops
+
+let add_wop t ty path = t.ops <- (ty, path) :: t.ops
+let set_read_lowpath t path = t.read_lowpath <- get_lowest path t.read_lowpath
+let set_write_lowpath t path = t.write_lowpath <- get_lowest path t.write_lowpath
+
+let path_exists t path = Store.path_exists t.store path
+
+let write t perm path value =
+	let path_exists = path_exists t path in
+	Store.write t.store perm path value;
+	if path_exists
+	then set_write_lowpath t path
+	else set_write_lowpath t (Store.Path.get_parent path);
+	add_wop t Xb.Op.Write path
+
+let mkdir ?(with_watch=true) t perm path =
+	Store.mkdir t.store perm path;
+	set_write_lowpath t path;
+	if with_watch then
+		add_wop t Xb.Op.Mkdir path
+
+let setperms t perm path perms =
+	Store.setperms t.store perm path perms;
+	set_write_lowpath t path;
+	add_wop t Xb.Op.Setperms path
+
+let rm t perm path =
+	Store.rm t.store perm path;
+	set_write_lowpath t (Store.Path.get_parent path);
+	add_wop t Xb.Op.Rm path
+
+let ls t perm path =	
+	let r = Store.ls t.store perm path in
+	set_read_lowpath t path;
+	r
+
+let read t perm path =
+	let r = Store.read t.store perm path in
+	set_read_lowpath t path;
+	r
+
+let getperms t perm path =
+	let r = Store.getperms t.store perm path in
+	set_read_lowpath t path;
+	r
+
+let commit ~con t =
+	let has_write_ops = List.length t.ops > 0 in
+	let has_coalesced = ref false in
+	let has_commited =
+	match t.ty with
+	| No                         -> true
+	| Full (id, oldroot, cstore) ->
+		let commit_partial oldroot cstore store =
+			(* get the lowest path of the query and verify that it hasn't
+			   been modified by others transactions. *)
+			if can_coalesce oldroot (Store.get_root cstore) t.read_lowpath
+			&& can_coalesce oldroot (Store.get_root cstore) t.write_lowpath then (
+				maybe (fun p ->
+					let n = Store.get_node store p in
+
+					(* it has to be in the store, otherwise it means bugs
+					   in the lowpath registration. we don't need to handle none. *)
+					maybe (fun n -> Store.set_node cstore p n) n;
+					Logging.write_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p);
+				) t.write_lowpath;
+				maybe (fun p ->
+					Logging.read_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p)
+					) t.read_lowpath;
+				has_coalesced := true;
+				Store.incr_transaction_coalesce cstore;
+				true
+			) else (
+				(* cannot do anything simple, just discard the queries,
+				   and the client need to redo it later *)
+				Store.incr_transaction_abort cstore;
+				false
+			)
+			in
+		let try_commit oldroot cstore store =
+			if oldroot == Store.get_root cstore then (
+				(* move the new root to the current store, if the oldroot
+				   has not been modified *)
+				if has_write_ops then (
+					Store.set_root cstore (Store.get_root store);
+					Store.set_quota cstore (Store.get_quota store)
+				);
+				true
+			) else
+				(* we try a partial commit if possible *)
+				commit_partial oldroot cstore store
+			in
+		if !test_eagain && Random.int 3 = 0 then
+			false
+		else
+			try_commit oldroot cstore t.store
+		in
+	if has_commited && has_write_ops then
+		Disk.write t.store;
+	if not has_commited 
+	then Logging.conflict ~tid:(get_id t) ~con
+	else if not !has_coalesced 
+	then Logging.commit ~tid:(get_id t) ~con;
+	has_commited

tools/ocaml/xenstored/utils.ml

@@ -0,0 +1,107 @@
+(*
+ * 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.
+ *)
+
+open Printf
+open Stdext
+
+(* lists utils *)
+let filter_out filter l =
+	List.filter (fun x -> not (List.mem x filter)) l
+
+let filter_in filter l =
+	List.filter (fun x -> List.mem x filter) l
+
+let list_remove element l =
+	List.filter (fun e -> e != element) l
+
+let list_tl_multi n l =
+	let rec do_tl i x =
+		if i = 0 then x else do_tl (i - 1) (List.tl x)
+		in
+	do_tl n l
+
+(* string utils *)
+let get_hierarchy path =
+	let l = List.length path in
+	let revpath = List.rev path in
+	let rec sub i =
+		let x = List.rev (list_tl_multi (l - i) revpath) in
+		if i = l then [ x ] else x :: sub (i + 1)
+		in
+	sub 0
+
+let hexify s =
+	let hexseq_of_char c = sprintf "%02x" (Char.code c) in
+	let hs = String.create (String.length s * 2) in
+	for i = 0 to String.length s - 1
+	do
+		let seq = hexseq_of_char s.[i] in
+		hs.[i * 2] <- seq.[0];
+		hs.[i * 2 + 1] <- seq.[1];
+	done;
+	hs
+
+let unhexify hs =
+	let char_of_hexseq seq0 seq1 = Char.chr (int_of_string (sprintf "0x%c%c" seq0 seq1)) in
+	let s = String.create (String.length hs / 2) in
+	for i = 0 to String.length s - 1
+	do
+		s.[i] <- char_of_hexseq hs.[i * 2] hs.[i * 2 + 1]
+	done;
+	s
+
+let trim_path path =
+	try
+		let rindex = String.rindex path '/' in
+		String.sub path 0 rindex
+	with
+		Not_found -> ""
+
+let join_by_null ls = String.concat "\000" ls
+
+(* unix utils *)
+let create_unix_socket name =
+	Unixext.unlink_safe name;
+	Unixext.mkdir_rec (Filename.dirname name) 0o700;
+	let sockaddr = Unix.ADDR_UNIX(name) in
+	let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+	Unix.bind sock sockaddr;
+	Unix.listen sock 1;
+	sock
+
+let read_file_single_integer filename =
+	let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in
+	let buf = String.make 20 (char_of_int 0) in
+	let sz = Unix.read fd buf 0 20 in
+	Unix.close fd;
+	int_of_string (String.sub buf 0 sz)
+
+let path_complete path connection_path =
+	if String.get path 0 <> '/' then
+		connection_path ^ path
+	else
+		path
+
+let path_validate path connection_path =
+	if String.length path = 0 || String.length path > 1024 then
+		raise Define.Invalid_path
+	else
+		let cpath = path_complete path connection_path in
+		if String.get cpath 0 <> '/' then
+			raise Define.Invalid_path
+		else
+			cpath
+

tools/ocaml/xenstored/xenstored.conf

@@ -0,0 +1,30 @@
+# default xenstored config
+
+# Where the pid file is stored
+pid-file = /var/run/xensource/xenstored.pid
+
+# Randomly failed a transaction with EAGAIN. Used for testing Xs user
+test-eagain = true
+
+# Activate transaction merge support
+merge-activate = true
+
+# Activate node permission system
+perms-activate = true
+
+# Activate quota
+quota-activate = true
+quota-maxentity = 1000
+quota-maxsize = 2048
+quota-maxwatch = 100
+quota-transaction = 10
+
+# Activate filed base backend
+persistant = false
+
+# Logs
+log = error;general;file:/var/log/xenstored.log
+log = warn;general;file:/var/log/xenstored.log
+log = info;general;file:/var/log/xenstored.log
+
+# log = debug;io;file:/var/log/xenstored-io.log

tools/ocaml/xenstored/xenstored.ml

@@ -0,0 +1,404 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@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.
+ *)
+
+open Printf
+open Parse_arg
+open Stdext
+open Logging
+
+(*------------ event klass processors --------------*)
+let process_connection_fds store cons domains rset wset =
+	let try_fct fct c =
+		try
+			fct store cons domains c
+		with
+		| Unix.Unix_error(err, "write", _) ->
+			Connections.del_anonymous cons c;
+			error "closing socket connection: write error: %s"
+			      (Unix.error_message err)
+		| Unix.Unix_error(err, "read", _) ->
+			Connections.del_anonymous cons c;
+			if err <> Unix.ECONNRESET then
+			error "closing socket connection: read error: %s"
+			      (Unix.error_message err)
+		| Xb.End_of_file ->
+			Connections.del_anonymous cons c;
+			debug "closing socket connection"
+		in
+	let process_fdset_with fds fct =
+		List.iter (fun fd ->
+		           try try_fct fct (Connections.find cons fd)
+		           with Not_found -> ()) fds
+	in
+	process_fdset_with rset Process.do_input;
+	process_fdset_with wset Process.do_output
+
+let process_domains store cons domains =
+	let do_io_domain domain =
+		let con = Connections.find_domain cons (Domain.get_id domain) in
+		Process.do_input store cons domains con;
+		Process.do_output store cons domains con in
+	Domains.iter domains do_io_domain
+
+let sigusr1_handler store =
+	try
+		let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ]
+		                           0o600 "/var/run/xenstored/db.debug" in
+		finally (fun () -> Store.dump store channel)
+			(fun () -> close_out channel)
+	with _ ->
+		()
+
+let sighup_handler _ =
+	try Logs.reopen (); info "Log re-opened" with _ -> ()
+
+let config_filename cf =
+	match cf.config_file with
+	| Some name -> name
+	| None      -> Define.default_config_dir ^ "/xenstored.conf"
+
+let default_pidfile = "/var/run/xenstored.pid"
+
+let parse_config filename =
+	let pidfile = ref default_pidfile in
+	let set_log s =
+		let ls = String.split ~limit:3 ';' s in
+		let level, key, logger = match ls with
+		| [ level; key; logger ] -> level, key, logger
+		| _ -> failwith "format mismatch: expecting 3 arguments" in
+
+		let loglevel = match level with
+		| "debug" -> Log.Debug
+		| "info"  -> Log.Info
+		| "warn"  -> Log.Warn
+		| "error" -> Log.Error
+		| s       -> failwith (sprintf "Unknown log level: %s" s) in
+
+		(* if key is empty, append to the default logger *)
+		let append =
+			if key = "" then
+				Logs.append_default
+			else
+				Logs.append key in
+		append loglevel logger in
+	let options = [
+		("merge-activate", Config.Set_bool Transaction.do_coalesce);
+		("perms-activate", Config.Set_bool Perms.activate);
+		("quota-activate", Config.Set_bool Quota.activate);
+		("quota-maxwatch", Config.Set_int Define.maxwatch);
+		("quota-transaction", Config.Set_int Define.maxtransaction);
+		("quota-maxentity", Config.Set_int Quota.maxent);
+		("quota-maxsize", Config.Set_int Quota.maxsize);
+		("test-eagain", Config.Set_bool Transaction.test_eagain);
+		("log", Config.String set_log);
+		("persistant", Config.Set_bool Disk.enable);
+		("access-log-file", Config.Set_string Logging.access_log_file);
+		("access-log-nb-files", Config.Set_int Logging.access_log_nb_files);
+		("access-log-nb-lines", Config.Set_int Logging.access_log_nb_lines);
+		("access-log-read-ops", Config.Set_bool Logging.log_read_ops);
+		("access-log-transactions-ops", Config.Set_bool Logging.log_transaction_ops);
+		("access-log-special-ops", Config.Set_bool Logging.log_special_ops);
+		("allow-debug", Config.Set_bool Process.allow_debug);
+		("pid-file", Config.Set_string pidfile); ] in
+	begin try Config.read filename options (fun _ _ -> raise Not_found)
+	with
+	| Config.Error err -> List.iter (fun (k, e) ->
+		match e with
+		| "unknown key" -> eprintf "config: unknown key %s\n" k
+		| _             -> eprintf "config: %s: %s\n" k e
+		) err;
+	| Sys_error m -> eprintf "error: config: %s\n" m;
+	end;
+	!pidfile
+
+module DB = struct
+
+exception Bad_format of string
+
+let dump_format_header = "$xenstored-dump-format"
+
+let from_channel_f chan domain_f watch_f store_f =
+	let unhexify s = Utils.unhexify s in
+	let getpath s = Store.Path.of_string (Utils.unhexify s) in
+	let header = input_line chan in
+	if header <> dump_format_header then
+		raise (Bad_format "header");
+	let quit = ref false in
+	while not !quit
+	do
+		try
+			let line = input_line chan in
+			let l = String.split ',' line in
+			try
+				match l with
+				| "dom" :: domid :: mfn :: port :: []->
+					domain_f (int_of_string domid)
+					         (Nativeint.of_string mfn)
+					         (int_of_string port)
+				| "watch" :: domid :: path :: token :: [] ->
+					watch_f (int_of_string domid)
+					        (unhexify path) (unhexify token)
+				| "store" :: path :: perms :: value :: [] ->
+					store_f (getpath path)
+					        (Perms.Node.of_string (unhexify perms ^ "\000"))
+					        (unhexify value)
+				| _ ->
+					info "restoring: ignoring unknown line: %s" line
+			with exn ->
+				info "restoring: ignoring unknown line: %s (exception: %s)"
+				     line (Printexc.to_string exn);
+				()
+		with End_of_file ->
+			quit := true
+	done;
+	()
+
+let from_channel store cons doms chan =
+	(* don't let the permission get on our way, full perm ! *)
+	let op = Store.get_ops store Perms.Connection.full_rights in
+	let xc = Xc.interface_open () in
+
+	let domain_f domid mfn port =
+		let ndom =
+			if domid > 0 then
+				Domains.create xc doms domid mfn port
+			else
+				Domains.create0 false doms
+			in
+		Connections.add_domain cons ndom;
+		in
+	let watch_f domid path token = 
+		let con = Connections.find_domain cons domid in
+		ignore (Connections.add_watch cons con path token)
+		in
+	let store_f path perms value =
+		op.Store.write path value;
+		op.Store.setperms path perms
+		in
+	finally (fun () -> from_channel_f chan domain_f watch_f store_f)
+	        (fun () -> Xc.interface_close xc)
+
+let from_file store cons doms file =
+	let channel = open_in file in
+	finally (fun () -> from_channel store doms cons channel)
+	        (fun () -> close_in channel)
+
+let to_channel store cons chan =
+	let hexify s = Utils.hexify s in
+
+	fprintf chan "%s\n" dump_format_header;
+
+	(* dump connections related to domains; domid, mfn, eventchn port, watches *)
+	Connections.iter_domains cons (fun con -> Connection.dump con chan);
+
+	(* dump the store *)
+	Store.dump_fct store (fun path node ->
+		let name, perms, value = Store.Node.unpack node in
+		let fullpath = (Store.Path.to_string path) ^ "/" ^ name in
+		let permstr = Perms.Node.to_string perms in
+		fprintf chan "store,%s,%s,%s\n" (hexify fullpath) (hexify permstr) (hexify value)
+	);
+	flush chan;
+	()
+
+
+let to_file store cons file =
+	let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] 0o600 file in
+	finally (fun () -> to_channel store cons channel)
+	        (fun () -> close_out channel)
+end
+
+let _ =
+	printf "Xen Storage Daemon, version %d.%d\n%!"
+	       Define.xenstored_major Define.xenstored_minor;
+
+	let cf = do_argv in
+	let pidfile =
+		if Sys.file_exists (config_filename cf) then
+			parse_config (config_filename cf)
+		else
+			default_pidfile
+		in
+
+	(try 
+		Unixext.mkdir_rec (Filename.dirname pidfile) 0o755
+	with _ ->
+		()
+	);
+
+	let rw_sock, ro_sock =
+		if cf.disable_socket then
+			None, None
+		else
+			Some (Unix.handle_unix_error Utils.create_unix_socket Define.xs_daemon_socket),
+			Some (Unix.handle_unix_error Utils.create_unix_socket Define.xs_daemon_socket_ro)
+		in
+	
+	if cf.daemonize then
+		Unixext.daemonize ();
+
+	(try Unixext.pidfile_write pidfile with _ -> ());
+
+	info "Xen Storage Daemon, version %d.%d"
+	     Define.xenstored_major Define.xenstored_minor;
+
+	(* for compatilibity with old xenstored *)
+	begin match cf.pidfile with
+	| Some pidfile -> Unixext.pidfile_write pidfile
+	| None         -> () end;
+
+	let store = Store.create () in
+	let eventchn = Event.init () in
+	let domains = Domains.init eventchn in
+	let cons = Connections.create () in
+
+	let quit = ref false in
+
+	if cf.restart then (
+		DB.from_file store domains cons "/var/run/xenstored/db";
+		Event.bind_virq eventchn
+	) else (
+		if !Disk.enable then (
+			info "reading store from disk";
+			Disk.read store
+		);
+
+		let localpath = Store.Path.of_string "/local" in
+		if not (Store.path_exists store localpath) then
+			Store.mkdir store (Perms.Connection.create 0) localpath;
+
+		if cf.domain_init then (
+			let usingxiu = Xc.using_injection () in
+			Connections.add_domain cons (Domains.create0 usingxiu domains);
+			Event.bind_virq eventchn
+		);
+	);
+
+	Sys.set_signal Sys.sighup (Sys.Signal_handle sighup_handler);
+	Sys.set_signal Sys.sigterm (Sys.Signal_handle (fun i -> quit := true));
+	Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun i -> sigusr1_handler store));
+	Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
+
+	Logging.init cf.activate_access_log (fun () -> DB.to_file store cons "/var/run/xenstored/db");
+
+	let spec_fds =
+		(match rw_sock with None -> [] | Some x -> [ x ]) @
+		(match ro_sock with None -> [] | Some x -> [ x ]) @
+		(if cf.domain_init then [ eventchn.Event.fd ] else [])
+		in
+
+	let xc = Xc.interface_open () in
+
+	let process_special_fds rset =
+		let accept_connection can_write fd =
+			let (cfd, addr) = Unix.accept fd in
+			debug "new connection through socket";
+			Connections.add_anonymous cons cfd can_write
+		and handle_eventchn fd =
+			let port = Event.read_port eventchn in
+			finally (fun () ->
+				if port = eventchn.Event.virq_port then (
+					let (notify, deaddom) = Domains.cleanup xc domains in
+					List.iter (Connections.del_domain cons) deaddom;
+					if deaddom <> [] || notify then
+						Connections.fire_spec_watches cons "@releaseDomain"
+				)
+			) (fun () -> Event.write_port eventchn port);
+		and do_if_set fd set fct =
+			if List.mem fd set then
+				fct fd in
+
+		maybe (fun fd -> do_if_set fd rset (accept_connection true)) rw_sock;
+		maybe (fun fd -> do_if_set fd rset (accept_connection false)) ro_sock;
+		do_if_set eventchn.Event.fd rset (handle_eventchn)
+		in
+
+	let last_stat_time = ref 0. in
+	let periodic_ops_counter = ref 0 in
+	let periodic_ops () =
+		(* we garbage collect the string->int dictionary after a sizeable amount of operations,
+		 * there's no need to be really fast even if we got loose
+		 * objects since names are often reuse.
+		 *)
+		if Symbol.created () > 1000 || Symbol.used () > 20000
+		then begin
+			Symbol.mark_all_as_unused ();
+			Store.mark_symbols store;
+			Connections.iter cons Connection.mark_symbols;
+			Symbol.garbage ()
+		end;
+
+		(* make sure we don't print general stats faster than 2 min *)
+		let ntime = Unix.gettimeofday () in
+		if ntime > (!last_stat_time +. 120.) then (
+			last_stat_time := ntime;
+
+			let gc = Gc.stat () in
+			let (lanon, lanon_ops, lanon_watchs,
+			     ldom, ldom_ops, ldom_watchs) = Connections.stats cons in
+			let store_nodes, store_abort, store_coalesce = Store.stats store in
+			let symtbl_len = Symbol.stats () in
+
+			info "store stat: nodes(%d) t-abort(%d) t-coalesce(%d)"
+			     store_nodes store_abort store_coalesce;
+			info "sytbl stat: %d" symtbl_len;
+			info "  con stat: anonymous(%d, %d o, %d w) domains(%d, %d o, %d w)"
+			     lanon lanon_ops lanon_watchs ldom ldom_ops ldom_watchs;
+			info "  mem stat: minor(%.0f) promoted(%.0f) major(%.0f) heap(%d w, %d c) live(%d w, %d b) free(%d w, %d b)"
+			     gc.Gc.minor_words gc.Gc.promoted_words gc.Gc.major_words
+			     gc.Gc.heap_words gc.Gc.heap_chunks
+			     gc.Gc.live_words gc.Gc.live_blocks
+			     gc.Gc.free_words gc.Gc.free_blocks
+		)
+		in
+
+	let main_loop () =
+		incr periodic_ops_counter;
+		if !periodic_ops_counter > 20 then (
+			periodic_ops_counter := 0;
+			periodic_ops ();
+		);
+
+		let mw = Connections.has_more_work cons in
+		let inset, outset = Connections.select cons in
+		let timeout = if List.length mw > 0 then 0. else -1. in
+		let rset, wset, _ =
+		try
+			Unix.select (spec_fds @ inset) outset [] timeout
+		with Unix.Unix_error(Unix.EINTR, _, _) ->
+			[], [], [] in
+		let sfds, cfds =
+			List.partition (fun fd -> List.mem fd spec_fds) rset in
+		if List.length sfds > 0 then
+			process_special_fds sfds;
+		if List.length cfds > 0 || List.length wset > 0 then
+			process_connection_fds store cons domains cfds wset;
+		process_domains store cons domains
+		in
+
+	while not !quit
+	do
+		try
+			main_loop ()
+		with exc ->
+			error "caught exception %s" (Printexc.to_string exc);
+			if cf.reraise_top_level then
+				raise exc
+	done;
+	info "stopping xenstored";
+	DB.to_file store cons "/var/run/xenstored/db";
+	()