Commit 98148899 authored by Keir Fraser's avatar Keir Fraser

ocaml: Add xenstored implementation.

Signed-off-by: default avatarVincent Hanquez <vincent.hanquez@eu.citrix.com>
parent 4f21062b
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
(*
* Copyright (C) 2006-2007 XenSource Ltd.
* Copyright (C) 2008 Citrix Ltd.
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
type ty =
| Set_bool of bool ref
| Set_int of int ref
| Set_string of string ref
| Set_float of float ref
| Unit of (unit -> unit)
| Bool of (bool -> unit)
| Int of (int -> unit)
| String of (string -> unit)
| Float of (float -> unit)
exception Error of (string * string) list
let trim_start lc s =
let len = String.length s and i = ref 0 in
while !i < len && (List.mem s.[!i] lc)
do
incr i
done;
if !i < len then String.sub s !i (len - !i) else ""
let trim_end lc s =
let i = ref (String.length s - 1) in
while !i > 0 && (List.mem s.[!i] lc)
do
decr i
done;
if !i >= 0 then String.sub s 0 (!i + 1) else ""
let rec split ?limit:(limit=(-1)) c s =
let i = try String.index s c with Not_found -> -1 in
let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in
if i = -1 || nlimit = 0 then
[ s ]
else
let a = String.sub s 0 i
and b = String.sub s (i + 1) (String.length s - i - 1) in
a :: (split ~limit: nlimit c b)
let parse_line stream =
let lc = [ ' '; '\t' ] in
let trim_spaces s = trim_end lc (trim_start lc s) in
let to_config s =
match split ~limit:2 '=' s with
| k :: v :: [] -> Some (trim_end lc k, trim_start lc v)
| _ -> None in
let rec read_filter_line () =
try
let line = trim_spaces (input_line stream) in
if String.length line > 0 && line.[0] <> '#' then
match to_config line with
| None -> read_filter_line ()
| Some x -> x :: read_filter_line ()
else
read_filter_line ()
with
End_of_file -> [] in
read_filter_line ()
let parse filename =
let stream = open_in filename in
let cf = parse_line stream in
close_in stream;
cf
let validate cf expected other =
let err = ref [] in
let append x = err := x :: !err in
List.iter (fun (k, v) ->
try
if not (List.mem_assoc k expected) then
other k v
else let ty = List.assoc k expected in
match ty with
| Unit f -> f ()
| Bool f -> f (bool_of_string v)
| String f -> f v
| Int f -> f (int_of_string v)
| Float f -> f (float_of_string v)
| Set_bool r -> r := (bool_of_string v)
| Set_string r -> r := v
| Set_int r -> r := int_of_string v
| Set_float r -> r := (float_of_string v)
with
| Not_found -> append (k, "unknown key")
| Failure "int_of_string" -> append (k, "expect int arg")
| Failure "bool_of_string" -> append (k, "expect bool arg")
| Failure "float_of_string" -> append (k, "expect float arg")
| exn -> append (k, Printexc.to_string exn)
) cf;
if !err != [] then raise (Error !err)
(** read a filename, parse and validate, and return the errors if any *)
let read filename expected other =
let cf = parse filename in
validate cf expected other
(*
* Copyright (C) 2006-2007 XenSource Ltd.
* Copyright (C) 2008 Citrix Ltd.
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
exception End_of_file
open Stdext
type watch = {
con: t;
token: string;
path: string;
base: string;
is_relative: bool;
}
and t = {
xb: Xb.t;
dom: Domain.t option;
transactions: (int, Transaction.t) Hashtbl.t;
mutable next_tid: int;
watches: (string, watch list) Hashtbl.t;
mutable nb_watches: int;
anonid: int;
mutable stat_nb_ops: int;
mutable perm: Perms.Connection.t;
}
let get_path con =
Printf.sprintf "/local/domain/%i/" (match con.dom with None -> 0 | Some d -> Domain.get_id d)
let watch_create ~con ~path ~token = {
con = con;
token = token;
path = path;
base = get_path con;
is_relative = path.[0] <> '/' && path.[0] <> '@'
}
let get_con w = w.con
let number_of_transactions con =
Hashtbl.length con.transactions
let get_domain con = con.dom
let anon_id_next = ref 1
let get_domstr con =
match con.dom with
| None -> "A" ^ (string_of_int con.anonid)
| Some dom -> "D" ^ (string_of_int (Domain.get_id dom))
let make_perm dom =
let domid =
match dom with
| None -> 0
| Some d -> Domain.get_id d
in
Perms.Connection.create ~perms:[Perms.READ; Perms.WRITE] domid
let create xbcon dom =
let id =
match dom with
| None -> let old = !anon_id_next in incr anon_id_next; old
| Some _ -> 0
in
let con =
{
xb = xbcon;
dom = dom;
transactions = Hashtbl.create 5;
next_tid = 1;
watches = Hashtbl.create 8;
nb_watches = 0;
anonid = id;
stat_nb_ops = 0;
perm = make_perm dom;
}
in
Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con);
con
let get_fd con = Xb.get_fd con.xb
let close con =
Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con);
Xb.close con.xb
let get_perm con =
con.perm
let restrict con domid =
con.perm <- Perms.Connection.restrict con.perm domid
let set_target con target_domid =
con.perm <- Perms.Connection.set_target (get_perm con) ~perms:[Perms.READ; Perms.WRITE] target_domid
let send_reply con tid rid ty data =
Xb.queue con.xb (Xb.Packet.create tid rid ty data)
let send_error con tid rid err = send_reply con tid rid Xb.Op.Error (err ^ "\000")
let send_ack con tid rid ty = send_reply con tid rid ty "OK\000"
let get_watch_path con path =
if path.[0] = '@' || path.[0] = '/' then
path
else
let rpath = get_path con in
rpath ^ path
let get_watches (con: t) path =
if Hashtbl.mem con.watches path
then Hashtbl.find con.watches path
else []
let get_children_watches con path =
let path = path ^ "/" in
List.concat (Hashtbl.fold (fun p w l ->
if String.startswith path p then w :: l else l) con.watches [])
let is_dom0 con =
Perms.Connection.is_dom0 (get_perm con)
let add_watch con path token =
if !Quota.activate && !Define.maxwatch > 0 &&
not (is_dom0 con) && con.nb_watches > !Define.maxwatch then
raise Quota.Limit_reached;
let apath = get_watch_path con path in
let l = get_watches con apath in
if List.exists (fun w -> w.token = token) l then
raise Define.Already_exist;
let watch = watch_create ~con ~token ~path in
Hashtbl.replace con.watches apath (watch :: l);
con.nb_watches <- con.nb_watches + 1;
apath, watch
let del_watch con path token =
let apath = get_watch_path con path in
let ws = Hashtbl.find con.watches apath in
let w = List.find (fun w -> w.token = token) ws in
let filtered = Utils.list_remove w ws in
if List.length filtered > 0 then
Hashtbl.replace con.watches apath filtered
else
Hashtbl.remove con.watches apath;
con.nb_watches <- con.nb_watches - 1;
apath, w
let list_watches con =
let ll = Hashtbl.fold
(fun _ watches acc -> List.map (fun watch -> watch.path, watch.token) watches :: acc)
con.watches [] in
List.concat ll
let fire_single_watch watch =
let data = Utils.join_by_null [watch.path; watch.token; ""] in
send_reply watch.con Transaction.none 0 Xb.Op.Watchevent data
let fire_watch watch path =
let new_path =
if watch.is_relative && path.[0] = '/'
then begin
let n = String.length watch.base
and m = String.length path in
String.sub path n (m - n)
end else
path
in
let data = Utils.join_by_null [ new_path; watch.token; "" ] in
send_reply watch.con Transaction.none 0 Xb.Op.Watchevent data
let find_next_tid con =
let ret = con.next_tid in con.next_tid <- con.next_tid + 1; ret
let start_transaction con store =
if !Define.maxtransaction > 0 && not (is_dom0 con)
&& Hashtbl.length con.transactions > !Define.maxtransaction then
raise Quota.Transaction_opened;
let id = find_next_tid con in
let ntrans = Transaction.make id store in
Hashtbl.add con.transactions id ntrans;
Logging.start_transaction ~tid:id ~con:(get_domstr con);
id
let end_transaction con tid commit =
let trans = Hashtbl.find con.transactions tid in
Hashtbl.remove con.transactions tid;
Logging.end_transaction ~tid ~con:(get_domstr con);
if commit then Transaction.commit ~con:(get_domstr con) trans else true
let get_transaction con tid =
Hashtbl.find con.transactions tid
let do_input con = Xb.input con.xb
let has_input con = Xb.has_in_packet con.xb
let pop_in con = Xb.get_in_packet con.xb
let has_more_input con = Xb.has_more_input con.xb
let has_output con = Xb.has_output con.xb
let has_new_output con = Xb.has_new_output con.xb
let peek_output con = Xb.peek_output con.xb
let do_output con = Xb.output con.xb
let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
let mark_symbols con =
Hashtbl.iter (fun _ t -> Store.mark_symbols (Transaction.get_store t)) con.transactions
let stats con =
Hashtbl.length con.watches, con.stat_nb_ops
let dump con chan =
match con.dom with
| Some dom ->
let domid = Domain.get_id dom in
(* dump domain *)
Domain.dump dom chan;
(* dump watches *)
List.iter (fun (path, token) ->
Printf.fprintf chan "watch,%d,%s,%s\n" domid (Utils.hexify path) (Utils.hexify token)
) (list_watches con);
| None -> ()
(*
* Copyright (C) 2006-2007 XenSource Ltd.
* Copyright (C) 2008 Citrix Ltd.
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
* Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
let debug fmt = Logs.debug "general" fmt
type t = {
mutable anonymous: Connection.t list;
domains: (int, Connection.t) Hashtbl.t;
mutable watches: (string, Connection.watch list) Trie.t;
}
let create () = { anonymous = []; domains = Hashtbl.create 8; watches = Trie.create () }
let add_anonymous cons fd can_write =
let xbcon = Xb.open_fd fd in
let con = Connection.create xbcon None in
cons.anonymous <- con :: cons.anonymous
let add_domain cons dom =
let xbcon = Xb.open_mmap (Domain.get_interface dom) (fun () -> Domain.notify dom) in
let con = Connection.create xbcon (Some dom) in
Hashtbl.add cons.domains (Domain.get_id dom) con
let select cons =
let inset = List.map (fun c -> Connection.get_fd c) cons.anonymous
and outset = List.fold_left (fun l c -> if Connection.has_output c
then Connection.get_fd c :: l
else l) [] cons.anonymous in
inset, outset
let find cons fd =
List.find (fun c -> Connection.get_fd c = fd) cons.anonymous
let find_domain cons id =
Hashtbl.find cons.domains id
let del_watches_of_con con watches =
match List.filter (fun w -> Connection.get_con w != con) watches with
| [] -> None
| ws -> Some ws
let del_anonymous cons con =
try
cons.anonymous <- Utils.list_remove con cons.anonymous;
cons.watches <- Trie.map (del_watches_of_con con) cons.watches;
Connection.close con
with exn ->
debug "del anonymous %s" (Printexc.to_string exn)
let del_domain cons id =
try
let con = find_domain cons id in
Hashtbl.remove cons.domains id;
cons.watches <- Trie.map (del_watches_of_con con) cons.watches;
Connection.close con
with exn ->
debug "del domain %u: %s" id (Printexc.to_string exn)
let iter_domains cons fct =
Hashtbl.iter (fun k c -> fct c) cons.domains
let iter_anonymous cons fct =
List.iter (fun c -> fct c) (List.rev cons.anonymous)
let iter cons fct =
iter_domains cons fct; iter_anonymous cons fct
let has_more_work cons =
Hashtbl.fold (fun id con acc ->
if Connection.has_more_input con then
con :: acc
else
acc) cons.domains []
let key_of_str path =
if path.[0] = '@'
then [path]
else "" :: Store.Path.to_string_list (Store.Path.of_string path)
let key_of_path path =
"" :: Store.Path.to_string_list path
let add_watch cons con path token =
let apath, watch = Connection.add_watch con path token in
let key = key_of_str apath in
let watches =
if Trie.mem cons.watches key
then Trie.find cons.watches key
else []
in
cons.watches <- Trie.set cons.watches key (watch :: watches);
watch
let del_watch cons con path token =
let apath, watch = Connection.del_watch con path token in
let key = key_of_str apath in
let watches = Utils.list_remove watch (Trie.find cons.watches key) in
if watches = [] then
cons.watches <- Trie.unset cons.watches key
else
cons.watches <- Trie.set cons.watches key watches;
watch
(* path is absolute *)
let fire_watches cons path recurse =
let key = key_of_path path in
let path = Store.Path.to_string path in
let fire_watch _ = function
| None -> ()
| Some watches -> List.iter (fun w -> Connection.fire_watch w path) watches
in
let fire_rec x = function
| None -> ()
| Some watches ->
List.iter (fun w -> Connection.fire_single_watch w) watches
in
Trie.iter_path fire_watch cons.watches key;
if recurse then
Trie.iter fire_rec (Trie.sub cons.watches key)
let fire_spec_watches cons specpath =
iter cons (fun con ->
List.iter (fun w -> Connection.fire_single_watch w) (Connection.get_watches con specpath))
let set_target cons domain target_domain =
let con = find_domain cons domain in
Connection.set_target con target_domain
let number_of_transactions cons =
let res = ref 0 in
let aux con =
res := Connection.number_of_transactions con + !res
in
iter cons aux;
!res
let stats cons =
let nb_ops_anon = ref 0
and nb_watchs_anon = ref 0
and nb_ops_dom = ref 0
and nb_watchs_dom = ref 0 in
iter_anonymous cons (fun con ->
let con_watchs, con_ops = Connection.stats con in
nb_ops_anon := !nb_ops_anon + con_ops;
nb_watchs_anon := !nb_watchs_anon + con_watchs;
);
iter_domains cons (fun con ->
let con_watchs, con_ops = Connection.stats con in
nb_ops_dom := !nb_ops_dom + con_ops;
nb_watchs_dom := !nb_watchs_dom + con_watchs;
);
(List.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon,
Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom)
(*
* Copyright (C) 2006-2007 XenSource Ltd.
* Copyright (C) 2008 Citrix Ltd.
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
let xenstored_major = 1
let xenstored_minor = 0
let xenstored_proc_kva = "/proc/xen/xsd_kva"
let xenstored_proc_port = "/proc/xen/xsd_port"
let xs_daemon_socket = "/var/run/xenstored/socket"
let xs_daemon_socket_ro = "/var/run/xenstored/socket_ro"
let default_config_dir = "/etc/xensource"
let maxwatch = ref (50)
let maxtransaction = ref (20)
let domid_self = 0x7FF0
exception Not_a_directory of string
exception Not_a_value of string
exception Already_exist
exception Doesnt_exist
exception Lookup_Doesnt_exist of string
exception Invalid_path
exception Permission_denied
exception Unknown_operation
(*
* Copyright (C) 2006-2007 XenSource Ltd.
* Copyright (C) 2008 Citrix Ltd.
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
let enable = ref false
let xs_daemon_database = "/var/run/xenstored/db"
let error = Logs.error "general"
(* unescape utils *)
exception Bad_escape
let is_digit c = match c with '0' .. '9' -> true | _ -> false
let undec c =
match c with
| '0' .. '9' -> (Char.code c) - (Char.code '0')
| _ -> raise (Failure "undecify")
let unhex c =
let c = Char.lowercase c in
match c with
| '0' .. '9' -> (Char.code c) - (Char.code '0')
| 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10
| _ -> raise (Failure "unhexify")
let string_unescaped s =
let len = String.length s
and i = ref 0 in
let d = Buffer.create len in
let read_escape () =
incr i;
match s.[!i] with
| 'n' -> '\n'
| 'r' -> '\r'
| '\\' -> '\\'
| '\'' -> '\''
| '"' -> '"'
| 't' -> '\t'
| 'b' -> '\b'
| 'x' ->
let v = (unhex s.[!i + 1] * 16) + unhex s.[!i + 2] in
i := !i + 2;
Char.chr v
| c ->
if is_digit c then (
let v = (undec s.[!i]) * 100 +
(undec s.[!i + 1]) * 10 +
(undec s.[!i + 2]) in
i := !i + 2;
Char.chr v
) else
raise Bad_escape
in
while !i < len
do
let c = match s.[!i] with
| '\\' -> read_escape ()
| c -> c in
Buffer.add_char d c;
incr i
done;
Buffer.contents d
(* file -> lines_of_file *)
let file_readlines file =
let channel = open_in file in
let rec input_line_list channel =
let line = try input_line channel with End_of_file -> "" in
if String.length line > 0 then
line :: input_line_list channel
else (
close_in channel;
[]
) in
input_line_list channel
let rec map_string_list_range l s =
match l with
| [] -> []