Xen project Mailing List

[Xen-changelog] [xen-unstable] ocaml: Add xenstored implementation.

From: Xen patchbot-unstable <patchbot-unstable@xxxxxxxxxxxxxxxxxxx>

Date: Thu, 06 May 2010 04:10:31 -0700

Delivery-date: Thu, 06 May 2010 04:16:21 -0700

List-id: BK change log <xen-changelog.lists.xensource.com>

# 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

©2013 Xen Project, A Linux Foundation Collaborative Project. All Rights Reserved.
Linux Foundation is a registered trademark of The Linux Foundation.
Xen Project is a trademark of The Linux Foundation.