# HG changeset patch
# User Keir Fraser <keir.fraser@xxxxxxxxxx>
# Date 1273140279 -3600
# Node ID a9e3a8dfb269910115fb024249d69806588c7a7b
# Parent 8281b2dde2cfd109aa7956a2fb0ede95b063b5e2
ocaml: Add xenstored implementation.
Signed-off-by: Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
---
tools/ocaml/xenstored/Makefile | 54 ++++
tools/ocaml/xenstored/config.ml | 112 ++++++++
tools/ocaml/xenstored/connection.ml | 234 +++++++++++++++++
tools/ocaml/xenstored/connections.ml | 167 ++++++++++++
tools/ocaml/xenstored/define.ml | 40 +++
tools/ocaml/xenstored/disk.ml | 157 +++++++++++
tools/ocaml/xenstored/domain.ml | 62 ++++
tools/ocaml/xenstored/domains.ml | 84 ++++++
tools/ocaml/xenstored/event.ml | 29 ++
tools/ocaml/xenstored/logging.ml | 239 ++++++++++++++++++
tools/ocaml/xenstored/parse_arg.ml | 68 +++++
tools/ocaml/xenstored/perms.ml | 167 ++++++++++++
tools/ocaml/xenstored/process.ml | 396 ++++++++++++++++++++++++++++++
tools/ocaml/xenstored/quota.ml | 83 ++++++
tools/ocaml/xenstored/store.ml | 461 +++++++++++++++++++++++++++++++++++
tools/ocaml/xenstored/symbol.ml | 76 +++++
tools/ocaml/xenstored/symbol.mli | 52 +++
tools/ocaml/xenstored/transaction.ml | 198 +++++++++++++++
tools/ocaml/xenstored/utils.ml | 107 ++++++++
tools/ocaml/xenstored/xenstored.conf | 30 ++
tools/ocaml/xenstored/xenstored.ml | 404 ++++++++++++++++++++++++++++++
21 files changed, 3220 insertions(+)
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/Makefile
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/Makefile Thu May 06 11:04:39 2010 +0100
@@ -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
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/config.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/config.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,112 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/connection.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/connection.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,234 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 -> ()
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/connections.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/connections.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,167 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxxxxx>
+ *
+ * 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)
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/define.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/define.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,40 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/disk.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/disk.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,157 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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)
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/domain.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/domain.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,62 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/domains.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/domains.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,84 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/event.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/event.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,29 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/logging.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/logging.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,239 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
+ *
+ * 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)
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/parse_arg.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/parse_arg.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,68 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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;
+ }
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/perms.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/perms.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,167 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxxxxx>
+ *
+ * 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)
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/process.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/process.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,396 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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)
+ )
+
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/quota.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/quota.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,83 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/store.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/store.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,461 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxxxxx>
+ *
+ * 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
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/symbol.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/symbol.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,76 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxxxxx>
+ *
+ * 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
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/symbol.mli
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/symbol.mli Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,52 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxxxxx>
+ *
+ * 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 *)
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/transaction.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/transaction.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,198 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
+ *
+ * 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
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/utils.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/utils.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,107 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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
+
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/xenstored.conf
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/xenstored.conf Thu May 06 11:04:39 2010 +0100
@@ -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
diff -r 8281b2dde2cf -r a9e3a8dfb269 tools/ocaml/xenstored/xenstored.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/xenstored/xenstored.ml Thu May 06 11:04:39 2010 +0100
@@ -0,0 +1,404 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxxxxx>
+ *
+ * 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";
+ ()
_______________________________________________
Xen-changelog mailing list
Xen-changelog@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/xen-changelog
|
Home