xen-project/xen
1
0 Fork 0
mirror of https://github.com/xen-project/xen.git synced 2026-10-28 02:01:24 +01:00
Code Issues Activity

tools/ocaml: run 'make format' on OCaml files

Browse Source 
`git log -p -1 -w` proves the change here is only whitespace.

No functional change.

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
Acked-by: Christian Lindig <christian.lindig@citrix.com>
This commit is contained in:
Edwin Török authored and Andrew Cooper committed 2023-02-06 10:22:12 +00:00
1 parent aad8c1276c
commit ea250e81cf
45 files changed
+4228 -4228
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

tools/ocaml/libs/mmap/xenmmap.ml
+1 -1
View File
@@ -21,7 +21,7 @@ type mmap_map_flag = SHARED | PRIVATE
(* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *)
external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag
-> int -> int -> mmap_interface = "stub_mmap_init"
-> int -> int -> mmap_interface = "stub_mmap_init"
external unmap: mmap_interface -> unit = "stub_mmap_final"
(* read: interface -> start -> length -> data *)
external read: mmap_interface -> int -> int -> string = "stub_mmap_read"
tools/ocaml/libs/mmap/xenmmap.mli
+2 -2
View File
@@ -19,10 +19,10 @@ type mmap_prot_flag = RDONLY | WRONLY | RDWR
type mmap_map_flag = SHARED | PRIVATE
external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int
-> mmap_interface = "stub_mmap_init"
-> mmap_interface = "stub_mmap_init"
external unmap : mmap_interface -> unit = "stub_mmap_final"
external read : mmap_interface -> int -> int -> string = "stub_mmap_read"
external write : mmap_interface -> string -> int -> int -> unit
= "stub_mmap_write"
= "stub_mmap_write"
external getpagesize : unit -> int = "stub_mmap_getpagesize"
tools/ocaml/libs/xb/op.ml
+38 -38
View File
@@ -23,50 +23,50 @@ type operation = Debug | Directory | Read | Getperms |
Invalid
let operation_c_mapping =
[| Debug; Directory; Read; Getperms;
Watch; Unwatch; Transaction_start;
Transaction_end; Introduce; Release;
Getdomainpath; Write; Mkdir; Rm;
Setperms; Watchevent; Error; Isintroduced;
Resume; Set_target; Invalid; Reset_watches |]
[| Debug; Directory; Read; Getperms;
Watch; Unwatch; Transaction_start;
Transaction_end; Introduce; Release;
Getdomainpath; Write; Mkdir; Rm;
Setperms; Watchevent; Error; Isintroduced;
Resume; Set_target; Invalid; Reset_watches |]
let size = Array.length operation_c_mapping
let array_search el a =
let len = Array.length a in
let rec search i =
if i > len then raise Not_found;
if a.(i) = el then i else search (i + 1) in
search 0
let len = Array.length a in
let rec search i =
if i > len then raise Not_found;
if a.(i) = el then i else search (i + 1) in
search 0
let of_cval i =
if i >= 0 && i < size
then operation_c_mapping.(i)
else Invalid
if i >= 0 && i < size
then operation_c_mapping.(i)
else Invalid
let to_cval op =
array_search op operation_c_mapping
array_search op operation_c_mapping
let to_string ty =
match ty with
| Debug -> "DEBUG"
| Directory -> "DIRECTORY"
| Read -> "READ"
| Getperms -> "GET_PERMS"
| Watch -> "WATCH"
| Unwatch -> "UNWATCH"
| Transaction_start -> "TRANSACTION_START"
| Transaction_end -> "TRANSACTION_END"
| Introduce -> "INTRODUCE"
| Release -> "RELEASE"
| Getdomainpath -> "GET_DOMAIN_PATH"
| Write -> "WRITE"
| Mkdir -> "MKDIR"
| Rm -> "RM"
| Setperms -> "SET_PERMS"
| Watchevent -> "WATCH_EVENT"
| Error -> "ERROR"
| Isintroduced -> "IS_INTRODUCED"
| Resume -> "RESUME"
| Set_target -> "SET_TARGET"
| Reset_watches -> "RESET_WATCHES"
| Invalid -> "INVALID"
match ty with
| Debug -> "DEBUG"
| Directory -> "DIRECTORY"
| Read -> "READ"
| Getperms -> "GET_PERMS"
| Watch -> "WATCH"
| Unwatch -> "UNWATCH"
| Transaction_start -> "TRANSACTION_START"
| Transaction_end -> "TRANSACTION_END"
| Introduce -> "INTRODUCE"
| Release -> "RELEASE"
| Getdomainpath -> "GET_DOMAIN_PATH"
| Write -> "WRITE"
| Mkdir -> "MKDIR"
| Rm -> "RM"
| Setperms -> "SET_PERMS"
| Watchevent -> "WATCH_EVENT"
| Error -> "ERROR"
| Isintroduced -> "IS_INTRODUCED"
| Resume -> "RESUME"
| Set_target -> "SET_TARGET"
| Reset_watches -> "RESET_WATCHES"
| Invalid -> "INVALID"
tools/ocaml/libs/xb/packet.ml
+15 -15
View File
@@ -15,12 +15,12 @@
*)
type t =
{
tid: int;
rid: int;
ty: Op.operation;
data: string;
}
{
tid: int;
rid: int;
ty: Op.operation;
data: string;
}
exception Error of string
exception DataError of string
@@ -30,21 +30,21 @@ external string_of_header: int -> int -> int -> int -> string = "stub_string_of_
let create tid rid ty data = { tid = tid; rid = rid; ty = ty; data = data; }
let of_partialpkt ppkt =
create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.contents ppkt.Partial.buf)
create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.contents ppkt.Partial.buf)
let to_string pkt =
let header = string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (String.length pkt.data) in
header ^ pkt.data
let header = string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (String.length pkt.data) in
header ^ pkt.data
let unpack pkt =
pkt.tid, pkt.rid, pkt.ty, pkt.data
pkt.tid, pkt.rid, pkt.ty, pkt.data
let get_tid pkt = pkt.tid
let get_ty pkt = pkt.ty
let get_data pkt =
let l = String.length pkt.data in
if l > 0 && pkt.data.[l - 1] = '\000' then
String.sub pkt.data 0 (l - 1)
else
pkt.data
let l = String.length pkt.data in
if l > 0 && pkt.data.[l - 1] = '\000' then
String.sub pkt.data 0 (l - 1)
else
pkt.data
let get_rid pkt = pkt.rid
tools/ocaml/libs/xb/partial.ml
+24 -24
View File
@@ -15,39 +15,39 @@
*)
type pkt =
{
tid: int;
rid: int;
ty: Op.operation;
len: int;
buf: Buffer.t;
}
{
tid: int;
rid: int;
ty: Op.operation;
len: int;
buf: Buffer.t;
}
external header_size: unit -> int = "stub_header_size"
external header_of_string_internal: string -> int * int * int * int
= "stub_header_of_string"
= "stub_header_of_string"
let xenstore_payload_max = 4096 (* xen/include/public/io/xs_wire.h *)
let xenstore_rel_path_max = 2048 (* xen/include/public/io/xs_wire.h *)
let of_string s =
let tid, rid, opint, dlen = header_of_string_internal s in
(* A packet which is bigger than xenstore_payload_max is illegal.
This will leave the guest connection is a bad state and will
be hard to recover from without restarting the connection
(ie rebooting the guest) *)
let dlen = max 0 (min xenstore_payload_max dlen) in
{
tid = tid;
rid = rid;
ty = (Op.of_cval opint);
len = dlen;
buf = Buffer.create dlen;
}
let tid, rid, opint, dlen = header_of_string_internal s in
(* A packet which is bigger than xenstore_payload_max is illegal.
This will leave the guest connection is a bad state and will
be hard to recover from without restarting the connection
(ie rebooting the guest) *)
let dlen = max 0 (min xenstore_payload_max dlen) in
{
tid = tid;
rid = rid;
ty = (Op.of_cval opint);
len = dlen;
buf = Buffer.create dlen;
}
let append pkt s sz =
if Buffer.length pkt.buf + sz > xenstore_payload_max then failwith "Buffer.add: cannot grow buffer";
Buffer.add_substring pkt.buf s 0 sz
if Buffer.length pkt.buf + sz > xenstore_payload_max then failwith "Buffer.add: cannot grow buffer";
Buffer.add_substring pkt.buf s 0 sz
let to_complete pkt =
pkt.len - (Buffer.length pkt.buf)
pkt.len - (Buffer.length pkt.buf)
tools/ocaml/libs/xb/xb.ml
+208 -208
View File
@@ -18,94 +18,94 @@ module Op = struct include Op end
module Packet = struct include Packet end
module BoundedQueue : sig
type ('a, 'b) t
type ('a, 'b) t
(** [create ~capacity ~classify ~limit] creates a queue with maximum [capacity] elements.
This is burst capacity, each element is further classified according to [classify],
and each class can have its own [limit].
[capacity] is enforced as an overall limit.
The [limit] can be dynamic, and can be smaller than the number of elements already queued of that class,
in which case those elements are considered to use "burst capacity".
*)
val create: capacity:int -> classify:('a -> 'b) -> limit:('b -> int) -> ('a, 'b) t
(** [create ~capacity ~classify ~limit] creates a queue with maximum [capacity] elements.
This is burst capacity, each element is further classified according to [classify],
and each class can have its own [limit].
[capacity] is enforced as an overall limit.
The [limit] can be dynamic, and can be smaller than the number of elements already queued of that class,
in which case those elements are considered to use "burst capacity".
*)
val create: capacity:int -> classify:('a -> 'b) -> limit:('b -> int) -> ('a, 'b) t
(** [clear q] discards all elements from [q] *)
val clear: ('a, 'b) t -> unit
(** [clear q] discards all elements from [q] *)
val clear: ('a, 'b) t -> unit
(** [can_push q] when [length q < capacity]. *)
val can_push: ('a, 'b) t -> 'b -> bool
(** [can_push q] when [length q < capacity]. *)
val can_push: ('a, 'b) t -> 'b -> bool
(** [push e q] adds [e] at the end of queue [q] if [can_push q], or returns [None]. *)
val push: 'a -> ('a, 'b) t -> unit option
(** [push e q] adds [e] at the end of queue [q] if [can_push q], or returns [None]. *)
val push: 'a -> ('a, 'b) t -> unit option
(** [pop q] removes and returns first element in [q], or raises [Queue.Empty]. *)
val pop: ('a, 'b) t -> 'a
(** [pop q] removes and returns first element in [q], or raises [Queue.Empty]. *)
val pop: ('a, 'b) t -> 'a
(** [peek q] returns the first element in [q], or raises [Queue.Empty]. *)
val peek : ('a, 'b) t -> 'a
(** [peek q] returns the first element in [q], or raises [Queue.Empty]. *)
val peek : ('a, 'b) t -> 'a
(** [length q] returns the current number of elements in [q] *)
val length: ('a, 'b) t -> int
(** [length q] returns the current number of elements in [q] *)
val length: ('a, 'b) t -> int
(** [debug string_of_class q] prints queue usage statistics in an unspecified internal format. *)
val debug: ('b -> string) -> (_, 'b) t -> string
(** [debug string_of_class q] prints queue usage statistics in an unspecified internal format. *)
val debug: ('b -> string) -> (_, 'b) t -> string
end = struct
type ('a, 'b) t =
{ q: 'a Queue.t
; capacity: int
; classify: 'a -> 'b
; limit: 'b -> int
; class_count: ('b, int) Hashtbl.t
}
type ('a, 'b) t =
{ q: 'a Queue.t
; capacity: int
; classify: 'a -> 'b
; limit: 'b -> int
; class_count: ('b, int) Hashtbl.t
}
let create ~capacity ~classify ~limit =
{ capacity; q = Queue.create (); classify; limit; class_count = Hashtbl.create 3 }
let create ~capacity ~classify ~limit =
{ capacity; q = Queue.create (); classify; limit; class_count = Hashtbl.create 3 }
let get_count t classification = try Hashtbl.find t.class_count classification with Not_found -> 0
let get_count t classification = try Hashtbl.find t.class_count classification with Not_found -> 0
let can_push_internal t classification class_count =
Queue.length t.q < t.capacity && class_count < t.limit classification
let can_push_internal t classification class_count =
Queue.length t.q < t.capacity && class_count < t.limit classification
let ok = Some ()
let ok = Some ()
let push e t =
let classification = t.classify e in
let class_count = get_count t classification in
if can_push_internal t classification class_count then begin
Queue.push e t.q;
Hashtbl.replace t.class_count classification (class_count + 1);
ok
end
else
None
let push e t =
let classification = t.classify e in
let class_count = get_count t classification in
if can_push_internal t classification class_count then begin
Queue.push e t.q;
Hashtbl.replace t.class_count classification (class_count + 1);
ok
end
else
None
let can_push t classification =
can_push_internal t classification @@ get_count t classification
let can_push t classification =
can_push_internal t classification @@ get_count t classification
let clear t =
Queue.clear t.q;
Hashtbl.reset t.class_count
let clear t =
Queue.clear t.q;
Hashtbl.reset t.class_count
let pop t =
let e = Queue.pop t.q in
let classification = t.classify e in
let () = match get_count t classification - 1 with
| 0 -> Hashtbl.remove t.class_count classification (* reduces memusage *)
| n -> Hashtbl.replace t.class_count classification n
in
e
let pop t =
let e = Queue.pop t.q in
let classification = t.classify e in
let () = match get_count t classification - 1 with
| 0 -> Hashtbl.remove t.class_count classification (* reduces memusage *)
| n -> Hashtbl.replace t.class_count classification n
in
e
let peek t = Queue.peek t.q
let length t = Queue.length t.q
let peek t = Queue.peek t.q
let length t = Queue.length t.q
let debug string_of_class t =
let b = Buffer.create 128 in
Printf.bprintf b "BoundedQueue capacity: %d, used: {" t.capacity;
Hashtbl.iter (fun packet_class count ->
Printf.bprintf b " %s: %d" (string_of_class packet_class) count
) t.class_count;
Printf.bprintf b "}";
Buffer.contents b
let debug string_of_class t =
let b = Buffer.create 128 in
Printf.bprintf b "BoundedQueue capacity: %d, used: {" t.capacity;
Hashtbl.iter (fun packet_class count ->
Printf.bprintf b " %s: %d" (string_of_class packet_class) count
) t.class_count;
Printf.bprintf b "}";
Buffer.contents b
end
@@ -119,16 +119,16 @@ let _ =
Callback.register_exception "Xb.Reconnect" Reconnect
type backend_mmap =
{
mmap: Xenmmap.mmap_interface; (* mmaped interface = xs_ring *)
eventchn_notify: unit -> unit; (* function to notify through eventchn *)
mutable work_again: bool;
}
{
mmap: Xenmmap.mmap_interface; (* mmaped interface = xs_ring *)
eventchn_notify: unit -> unit; (* function to notify through eventchn *)
mutable work_again: bool;
}
type backend_fd =
{
fd: Unix.file_descr;
}
{
fd: Unix.file_descr;
}
type backend = Fd of backend_fd | Xenmmap of backend_mmap
@@ -144,104 +144,104 @@ type capacity = { maxoutstanding: int; maxwatchevents: int }
module Queue = BoundedQueue
type packet_class =
| CommandReply
| Watchevent
| CommandReply
| Watchevent
let string_of_packet_class = function
| CommandReply -> "command_reply"
| Watchevent -> "watch_event"
| CommandReply -> "command_reply"
| Watchevent -> "watch_event"
type t =
{
backend: backend;
pkt_out: (Packet.t, packet_class) Queue.t;
mutable partial_in: partial_buf;
mutable partial_out: string;
capacity: capacity
}
{
backend: backend;
pkt_out: (Packet.t, packet_class) Queue.t;
mutable partial_in: partial_buf;
mutable partial_out: string;
capacity: capacity
}
let to_read con =
match con.partial_in with
| HaveHdr partial_pkt -> Partial.to_complete partial_pkt
| NoHdr (i, _) -> i
match con.partial_in with
| HaveHdr partial_pkt -> Partial.to_complete partial_pkt
| NoHdr (i, _) -> i
let debug t =
Printf.sprintf "XenBus state: partial_in: %d needed, partial_out: %d bytes, pkt_out: %d packets, %s"
(to_read t)
(String.length t.partial_out)
(Queue.length t.pkt_out)
(BoundedQueue.debug string_of_packet_class t.pkt_out)
Printf.sprintf "XenBus state: partial_in: %d needed, partial_out: %d bytes, pkt_out: %d packets, %s"
(to_read t)
(String.length t.partial_out)
(Queue.length t.pkt_out)
(BoundedQueue.debug string_of_packet_class t.pkt_out)
let init_partial_in () = NoHdr
(Partial.header_size (), Bytes.make (Partial.header_size()) '\000')
(Partial.header_size (), Bytes.make (Partial.header_size()) '\000')
let reconnect t = match t.backend with
| Fd _ ->
(* should never happen, so close the connection *)
raise End_of_file
| Xenmmap backend ->
Xs_ring.close backend.mmap;
backend.eventchn_notify ();
(* Clear our old connection state *)
Queue.clear t.pkt_out;
t.partial_in <- init_partial_in ();
t.partial_out <- ""
| Fd _ ->
(* should never happen, so close the connection *)
raise End_of_file
| Xenmmap backend ->
Xs_ring.close backend.mmap;
backend.eventchn_notify ();
(* Clear our old connection state *)
Queue.clear t.pkt_out;
t.partial_in <- init_partial_in ();
t.partial_out <- ""
let queue con pkt = Queue.push pkt con.pkt_out
let read_fd back _con b len =
let rd = Unix.read back.fd b 0 len in
if rd = 0 then
raise End_of_file;
rd
let rd = Unix.read back.fd b 0 len in
if rd = 0 then
raise End_of_file;
rd
let read_mmap back _con b len =
let s = Bytes.make len '\000' in
let rd = Xs_ring.read back.mmap s len in
Bytes.blit s 0 b 0 rd;
back.work_again <- (rd > 0);
if rd > 0 then
back.eventchn_notify ();
rd
let s = Bytes.make len '\000' in
let rd = Xs_ring.read back.mmap s len in
Bytes.blit s 0 b 0 rd;
back.work_again <- (rd > 0);
if rd > 0 then
back.eventchn_notify ();
rd
let read con b len =
match con.backend with
| Fd backfd -> read_fd backfd con b len
| Xenmmap backmmap -> read_mmap backmmap con b len
match con.backend with
| Fd backfd -> read_fd backfd con b len
| Xenmmap backmmap -> read_mmap backmmap con b len
let write_fd back _con b len =
Unix.write_substring back.fd b 0 len
Unix.write_substring back.fd b 0 len
let write_mmap back _con s len =
let ws = Xs_ring.write_substring back.mmap s len in
if ws > 0 then
back.eventchn_notify ();
ws
let ws = Xs_ring.write_substring back.mmap s len in
if ws > 0 then
back.eventchn_notify ();
ws
let write con s len =
match con.backend with
| Fd backfd -> write_fd backfd con s len
| Xenmmap backmmap -> write_mmap backmmap con s len
match con.backend with
| Fd backfd -> write_fd backfd con s len
| Xenmmap backmmap -> write_mmap backmmap con s len
(* NB: can throw Reconnect *)
let output con =
(* get the output string from a string_of(packet) or partial_out *)
let s = if String.length con.partial_out > 0 then
con.partial_out
else if Queue.length con.pkt_out > 0 then
let pkt = Queue.pop con.pkt_out in
Packet.to_string pkt
else
"" in
(* send data from s, and save the unsent data to partial_out *)
if s <> "" then (
let len = String.length s in
let sz = write con s len in
let left = String.sub s sz (len - sz) in
con.partial_out <- left
);
(* after sending one packet, partial is empty *)
con.partial_out = ""
(* get the output string from a string_of(packet) or partial_out *)
let s = if String.length con.partial_out > 0 then
con.partial_out
else if Queue.length con.pkt_out > 0 then
let pkt = Queue.pop con.pkt_out in
Packet.to_string pkt
else
"" in
(* send data from s, and save the unsent data to partial_out *)
if s <> "" then (
let len = String.length s in
let sz = write con s len in
let left = String.sub s sz (len - sz) in
con.partial_out <- left
);
(* after sending one packet, partial is empty *)
con.partial_out = ""
(* we can only process an input packet if we're guaranteed to have room
to store the response packet *)
@@ -249,71 +249,71 @@ let can_input con = Queue.can_push con.pkt_out CommandReply
(* NB: can throw Reconnect *)
let input con =
if not (can_input con) then None
else
let to_read = to_read con in
if not (can_input con) then None
else
let to_read = to_read con in
(* try to get more data from input stream *)
let b = Bytes.make to_read '\000' in
let sz = if to_read > 0 then read con b to_read else 0 in
(* try to get more data from input stream *)
let b = Bytes.make to_read '\000' in
let sz = if to_read > 0 then read con b to_read else 0 in
(
match con.partial_in with
| HaveHdr partial_pkt ->
(* we complete the data *)
if sz > 0 then
Partial.append partial_pkt (Bytes.to_string b) sz;
if Partial.to_complete partial_pkt = 0 then (
let pkt = Packet.of_partialpkt partial_pkt in
con.partial_in <- init_partial_in ();
Some pkt
) else None
| NoHdr (i, buf) ->
(* we complete the partial header *)
if sz > 0 then
Bytes.blit b 0 buf (Partial.header_size () - i) sz;
con.partial_in <- if sz = i then
HaveHdr (Partial.of_string (Bytes.to_string buf)) else NoHdr (i - sz, buf);
None
)
(
match con.partial_in with
| HaveHdr partial_pkt ->
(* we complete the data *)
if sz > 0 then
Partial.append partial_pkt (Bytes.to_string b) sz;
if Partial.to_complete partial_pkt = 0 then (
let pkt = Packet.of_partialpkt partial_pkt in
con.partial_in <- init_partial_in ();
Some pkt
) else None
| NoHdr (i, buf) ->
(* we complete the partial header *)
if sz > 0 then
Bytes.blit b 0 buf (Partial.header_size () - i) sz;
con.partial_in <- if sz = i then
HaveHdr (Partial.of_string (Bytes.to_string buf)) else NoHdr (i - sz, buf);
None
)
let classify t =
match t.Packet.ty with
| Op.Watchevent -> Watchevent
| _ -> CommandReply
match t.Packet.ty with
| Op.Watchevent -> Watchevent
| _ -> CommandReply
let newcon ~capacity backend =
let limit = function
| CommandReply -> capacity.maxoutstanding
| Watchevent -> capacity.maxwatchevents
in
{
backend = backend;
pkt_out = Queue.create ~capacity:(capacity.maxoutstanding + capacity.maxwatchevents) ~classify ~limit;
partial_in = init_partial_in ();
partial_out = "";
capacity = capacity;
}
let limit = function
| CommandReply -> capacity.maxoutstanding
| Watchevent -> capacity.maxwatchevents
in
{
backend = backend;
pkt_out = Queue.create ~capacity:(capacity.maxoutstanding + capacity.maxwatchevents) ~classify ~limit;
partial_in = init_partial_in ();
partial_out = "";
capacity = capacity;
}
let open_fd fd = newcon (Fd { fd = fd; })
let open_mmap mmap notifyfct =
(* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *)
Xs_ring.set_server_features mmap (Xs_ring.Server_features.singleton Xs_ring.Server_feature.Reconnection);
newcon (Xenmmap {
mmap = mmap;
eventchn_notify = notifyfct;
work_again = false; })
(* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *)
Xs_ring.set_server_features mmap (Xs_ring.Server_features.singleton Xs_ring.Server_feature.Reconnection);
newcon (Xenmmap {
mmap = mmap;
eventchn_notify = notifyfct;
work_again = false; })
let close con =
match con.backend with
| Fd backend -> Unix.close backend.fd
| Xenmmap backend -> Xenmmap.unmap backend.mmap
match con.backend with
| Fd backend -> Unix.close backend.fd
| Xenmmap backend -> Xenmmap.unmap backend.mmap
let is_fd con =
match con.backend with
| Fd _ -> true
| Xenmmap _ -> false
match con.backend with
| Fd _ -> true
| Xenmmap _ -> false
let is_mmap con = not (is_fd con)
@@ -326,19 +326,19 @@ let has_output con = has_new_output con || has_old_output con
let peek_output con = Queue.peek con.pkt_out
let has_partial_input con = match con.partial_in with
| HaveHdr _ -> true
| NoHdr (n, _) -> n < Partial.header_size ()
| HaveHdr _ -> true
| NoHdr (n, _) -> n < Partial.header_size ()
let has_more_input con =
match con.backend with
| Fd _ -> false
| Xenmmap backend -> backend.work_again
match con.backend with
| Fd _ -> false
| Xenmmap backend -> backend.work_again
let is_selectable con =
match con.backend with
| Fd _ -> true
| Xenmmap _ -> false
match con.backend with
| Fd _ -> true
| Xenmmap _ -> false
let get_fd con =
match con.backend with
| Fd backend -> backend.fd
| Xenmmap _ -> raise (Failure "get_fd")
match con.backend with
| Fd backend -> backend.fd
| Xenmmap _ -> raise (Failure "get_fd")
tools/ocaml/libs/xb/xb.mli
+53 -53
View File
@@ -1,58 +1,58 @@
module Op :
sig
type operation =
Op.operation =
Debug
| Directory
| Read
| Getperms
| Watch
| Unwatch
| Transaction_start
| Transaction_end
| Introduce
| Release
| Getdomainpath
| Write
| Mkdir
| Rm
| Setperms
| Watchevent
| Error
| Isintroduced
| Resume
| Set_target
| Reset_watches
| Invalid
val operation_c_mapping : operation array
val size : int
val array_search : 'a -> 'a array -> int
val of_cval : int -> operation
val to_cval : operation -> int
val to_string : operation -> string
end
sig
type operation =
Op.operation =
Debug
| Directory
| Read
| Getperms
| Watch
| Unwatch
| Transaction_start
| Transaction_end
| Introduce
| Release
| Getdomainpath
| Write
| Mkdir
| Rm
| Setperms
| Watchevent
| Error
| Isintroduced
| Resume
| Set_target
| Reset_watches
| Invalid
val operation_c_mapping : operation array
val size : int
val array_search : 'a -> 'a array -> int
val of_cval : int -> operation
val to_cval : operation -> int
val to_string : operation -> string
end
module Packet :
sig
type t =
Packet.t = {
tid : int;
rid : int;
ty : Op.operation;
data : string;
}
exception Error of string
exception DataError of string
external string_of_header : int -> int -> int -> int -> string
= "stub_string_of_header"
val create : int -> int -> Op.operation -> string -> t
val of_partialpkt : Partial.pkt -> t
val to_string : t -> string
val unpack : t -> int * int * Op.operation * string
val get_tid : t -> int
val get_ty : t -> Op.operation
val get_data : t -> string
val get_rid : t -> int
end
sig
type t =
Packet.t = {
tid : int;
rid : int;
ty : Op.operation;
data : string;
}
exception Error of string
exception DataError of string
external string_of_header : int -> int -> int -> int -> string
= "stub_string_of_header"
val create : int -> int -> Op.operation -> string -> t
val of_partialpkt : Partial.pkt -> t
val to_string : t -> string
val unpack : t -> int * int * Op.operation * string
val get_tid : t -> int
val get_ty : t -> Op.operation
val get_data : t -> string
val get_rid : t -> int
end
exception End_of_file
exception Eagain
exception Noent
tools/ocaml/libs/xb/xs_ring.ml
+13 -13
View File
@@ -15,14 +15,14 @@
*)
module Server_feature = struct
type t =
| Reconnection
type t =
| Reconnection
end
module Server_features = Set.Make(struct
type t = Server_feature.t
let compare = compare
end)
type t = Server_feature.t
let compare = compare
end)
external read: Xenmmap.mmap_interface -> bytes -> int -> int = "ml_interface_read"
external write_substring: Xenmmap.mmap_interface -> string -> int -> int = "ml_interface_write"
@@ -31,15 +31,15 @@ external _internal_set_server_features: Xenmmap.mmap_interface -> int -> unit =
external _internal_get_server_features: Xenmmap.mmap_interface -> int = "ml_interface_get_server_features" [@@noalloc]
let get_server_features mmap =
(* NB only one feature currently defined above *)
let x = _internal_get_server_features mmap in
if x = 0
then Server_features.empty
else Server_features.singleton Server_feature.Reconnection
(* NB only one feature currently defined above *)
let x = _internal_get_server_features mmap in
if x = 0
then Server_features.empty
else Server_features.singleton Server_feature.Reconnection
let set_server_features mmap set =
(* NB only one feature currently defined above *)
let x = if set = Server_features.empty then 0 else 1 in
_internal_set_server_features mmap x
(* NB only one feature currently defined above *)
let x = if set = Server_features.empty then 0 else 1 in
_internal_set_server_features mmap x
external close: Xenmmap.mmap_interface -> unit = "ml_interface_close" [@@noalloc]
tools/ocaml/libs/xc/xenctrl.ml
+163 -163
View File
@@ -20,153 +20,153 @@ type domid = int
(* ** xenctrl.h ** *)
type vcpuinfo =
{
online: bool;
blocked: bool;
running: bool;
cputime: int64;
cpumap: int32;
}
{
online: bool;
blocked: bool;
running: bool;
cputime: int64;
cpumap: int32;
}
type xen_arm_arch_domainconfig =
{
gic_version: int;
nr_spis: int;
clock_frequency: int32;
}
{
gic_version: int;
nr_spis: int;
clock_frequency: int32;
}
type x86_arch_emulation_flags =
| X86_EMU_LAPIC
| X86_EMU_HPET
| X86_EMU_PM
| X86_EMU_RTC
| X86_EMU_IOAPIC
| X86_EMU_PIC
| X86_EMU_VGA
| X86_EMU_IOMMU
| X86_EMU_PIT
| X86_EMU_USE_PIRQ
| X86_EMU_VPCI
| X86_EMU_LAPIC
| X86_EMU_HPET
| X86_EMU_PM
| X86_EMU_RTC
| X86_EMU_IOAPIC
| X86_EMU_PIC
| X86_EMU_VGA
| X86_EMU_IOMMU
| X86_EMU_PIT
| X86_EMU_USE_PIRQ
| X86_EMU_VPCI
type x86_arch_misc_flags =
| X86_MSR_RELAXED
| X86_MSR_RELAXED
type xen_x86_arch_domainconfig =
{
emulation_flags: x86_arch_emulation_flags list;
misc_flags: x86_arch_misc_flags list;
}
{
emulation_flags: x86_arch_emulation_flags list;
misc_flags: x86_arch_misc_flags list;
}
type arch_domainconfig =
| ARM of xen_arm_arch_domainconfig
| X86 of xen_x86_arch_domainconfig
| ARM of xen_arm_arch_domainconfig
| X86 of xen_x86_arch_domainconfig
type domain_create_flag =
| CDF_HVM
| CDF_HAP
| CDF_S3_INTEGRITY
| CDF_OOS_OFF
| CDF_XS_DOMAIN
| CDF_IOMMU
| CDF_NESTED_VIRT
| CDF_VPMU
| CDF_HVM
| CDF_HAP
| CDF_S3_INTEGRITY
| CDF_OOS_OFF
| CDF_XS_DOMAIN
| CDF_IOMMU
| CDF_NESTED_VIRT
| CDF_VPMU
type domain_create_iommu_opts =
| IOMMU_NO_SHAREPT
| IOMMU_NO_SHAREPT
type domctl_create_config =
{
ssidref: int32;
handle: string;
flags: domain_create_flag list;
iommu_opts: domain_create_iommu_opts list;
max_vcpus: int;
max_evtchn_port: int;
max_grant_frames: int;
max_maptrack_frames: int;
max_grant_version: int;
cpupool_id: int32;
arch: arch_domainconfig;
}
{
ssidref: int32;
handle: string;
flags: domain_create_flag list;
iommu_opts: domain_create_iommu_opts list;
max_vcpus: int;
max_evtchn_port: int;
max_grant_frames: int;
max_maptrack_frames: int;
max_grant_version: int;
cpupool_id: int32;
arch: arch_domainconfig;
}
type domaininfo =
{
domid : domid;
dying : bool;
shutdown : bool;
paused : bool;
blocked : bool;
running : bool;
hvm_guest : bool;
shutdown_code : int;
total_memory_pages: nativeint;
max_memory_pages : nativeint;
shared_info_frame : int64;
cpu_time : int64;
nr_online_vcpus : int;
max_vcpu_id : int;
ssidref : int32;
handle : int array;
arch_config : arch_domainconfig;
}
{
domid : domid;
dying : bool;
shutdown : bool;
paused : bool;
blocked : bool;
running : bool;
hvm_guest : bool;
shutdown_code : int;
total_memory_pages: nativeint;
max_memory_pages : nativeint;
shared_info_frame : int64;
cpu_time : int64;
nr_online_vcpus : int;
max_vcpu_id : int;
ssidref : int32;
handle : int array;
arch_config : arch_domainconfig;
}
type sched_control =
{
weight : int;
cap : int;
}
{
weight : int;
cap : int;
}
type physinfo_cap_flag =
| CAP_HVM
| CAP_PV
| CAP_DirectIO
| CAP_HAP
| CAP_Shadow
| CAP_IOMMU_HAP_PT_SHARE
| CAP_Vmtrace
| CAP_Vpmu
| CAP_Gnttab_v1
| CAP_Gnttab_v2
| CAP_HVM
| CAP_PV
| CAP_DirectIO
| CAP_HAP
| CAP_Shadow
| CAP_IOMMU_HAP_PT_SHARE
| CAP_Vmtrace
| CAP_Vpmu
| CAP_Gnttab_v1
| CAP_Gnttab_v2
type arm_physinfo_cap_flag
type x86_physinfo_cap_flag
type arch_physinfo_cap_flags =
| ARM of arm_physinfo_cap_flag list
| X86 of x86_physinfo_cap_flag list
| ARM of arm_physinfo_cap_flag list
| X86 of x86_physinfo_cap_flag list
type physinfo =
{
threads_per_core : int;
cores_per_socket : int;
nr_cpus : int;
max_node_id : int;
cpu_khz : int;
total_pages : nativeint;
free_pages : nativeint;
scrub_pages : nativeint;
(* XXX hw_cap *)
capabilities : physinfo_cap_flag list;
max_nr_cpus : int;
arch_capabilities : arch_physinfo_cap_flags;
}
{
threads_per_core : int;
cores_per_socket : int;
nr_cpus : int;
max_node_id : int;
cpu_khz : int;
total_pages : nativeint;
free_pages : nativeint;
scrub_pages : nativeint;
(* XXX hw_cap *)
capabilities : physinfo_cap_flag list;
max_nr_cpus : int;
arch_capabilities : arch_physinfo_cap_flags;
}
type version =
{
major : int;
minor : int;
extra : string;
}
{
major : int;
minor : int;
extra : string;
}
type compile_info =
{
compiler : string;
compile_by : string;
compile_domain : string;
compile_date : string;
}
{
compiler : string;
compile_by : string;
compile_domain : string;
compile_date : string;
}
type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Watchdog | Soft_reset
@@ -181,34 +181,34 @@ let handle = ref None
let get_handle () = !handle
let close_handle () =
match !handle with
| Some _ -> handle := None
| None -> ()
match !handle with
| Some _ -> handle := None
| None -> ()
let with_intf f =
match !handle with
| Some h -> f h
| None ->
let h =
try interface_open () with
| e ->
let msg = Printexc.to_string e in
failwith ("failed to open xenctrl: "^msg)
in
handle := Some h;
f h
match !handle with
| Some h -> f h
| None ->
let h =
try interface_open () with
| e ->
let msg = Printexc.to_string e in
failwith ("failed to open xenctrl: "^msg)
in
handle := Some h;
f h
external domain_create_stub: handle -> domid -> domctl_create_config -> domid
= "stub_xc_domain_create"
= "stub_xc_domain_create"
let domain_create handle ?(domid=0) config =
domain_create_stub handle domid config
domain_create_stub handle domid config
external domain_sethandle: handle -> domid -> string -> unit
= "stub_xc_domain_sethandle"
= "stub_xc_domain_sethandle"
external domain_max_vcpus: handle -> domid -> int -> unit
= "stub_xc_domain_max_vcpus"
= "stub_xc_domain_max_vcpus"
external domain_pause: handle -> domid -> unit = "stub_xc_domain_pause"
external domain_unpause: handle -> domid -> unit = "stub_xc_domain_unpause"
@@ -216,10 +216,10 @@ external domain_resume_fast: handle -> domid -> unit = "stub_xc_domain_resume_fa
external domain_destroy: handle -> domid -> unit = "stub_xc_domain_destroy"
external domain_shutdown: handle -> domid -> shutdown_reason -> unit
= "stub_xc_domain_shutdown"
= "stub_xc_domain_shutdown"
external _domain_getinfolist: handle -> domid -> int -> domaininfo list
= "stub_xc_domain_getinfolist"
= "stub_xc_domain_getinfolist"
let rev_append_fold acc e = List.rev_append e acc
@@ -228,53 +228,53 @@ let rev_append_fold acc e = List.rev_append e acc
* except it is tail recursive, whereas [List.concat] isn't.
* Example:
* rev_concat [[10;9;8];[7;6];[5]]] = [5; 6; 7; 8; 9; 10]
*)
*)
let rev_concat lst = List.fold_left rev_append_fold [] lst
let domain_getinfolist handle first_domain =
let nb = 1024 in
let rec __getlist lst from =
(* _domain_getinfolist returns domains in reverse order, largest first *)
match _domain_getinfolist handle from nb with
| [] -> rev_concat lst
| (hd :: _) as l -> __getlist (l :: lst) (hd.domid + 1)
in
__getlist [] first_domain
let nb = 1024 in
let rec __getlist lst from =
(* _domain_getinfolist returns domains in reverse order, largest first *)
match _domain_getinfolist handle from nb with
| [] -> rev_concat lst
| (hd :: _) as l -> __getlist (l :: lst) (hd.domid + 1)
in
__getlist [] first_domain
external domain_getinfo: handle -> domid -> domaininfo= "stub_xc_domain_getinfo"
external domain_get_vcpuinfo: handle -> int -> int -> vcpuinfo
= "stub_xc_vcpu_getinfo"
= "stub_xc_vcpu_getinfo"
external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit
= "stub_xc_domain_ioport_permission"
= "stub_xc_domain_ioport_permission"
external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit
= "stub_xc_domain_iomem_permission"
= "stub_xc_domain_iomem_permission"
external domain_irq_permission: handle -> domid -> int -> bool -> unit
= "stub_xc_domain_irq_permission"
= "stub_xc_domain_irq_permission"
external vcpu_affinity_set: handle -> domid -> int -> bool array -> unit
= "stub_xc_vcpu_setaffinity"
= "stub_xc_vcpu_setaffinity"
external vcpu_affinity_get: handle -> domid -> int -> bool array
= "stub_xc_vcpu_getaffinity"
= "stub_xc_vcpu_getaffinity"
external vcpu_context_get: handle -> domid -> int -> string
= "stub_xc_vcpu_context_get"
= "stub_xc_vcpu_context_get"
external sched_id: handle -> int = "stub_xc_sched_id"
external sched_credit_domain_set: handle -> domid -> sched_control -> unit
= "stub_sched_credit_domain_set"
= "stub_sched_credit_domain_set"
external sched_credit_domain_get: handle -> domid -> sched_control
= "stub_sched_credit_domain_get"
= "stub_sched_credit_domain_get"
external shadow_allocation_set: handle -> domid -> int -> unit
= "stub_shadow_allocation_set"
= "stub_shadow_allocation_set"
external shadow_allocation_get: handle -> domid -> int
= "stub_shadow_allocation_get"
= "stub_shadow_allocation_get"
external evtchn_alloc_unbound: handle -> domid -> domid -> int
= "stub_xc_evtchn_alloc_unbound"
= "stub_xc_evtchn_alloc_unbound"
external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset"
(* FIFO has theoretical maximum of 2^28 ports, fits in an int *)
@@ -299,15 +299,15 @@ external physinfo: handle -> physinfo = "stub_xc_physinfo"
external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info"
external domain_setmaxmem: handle -> domid -> int64 -> unit
= "stub_xc_domain_setmaxmem"
= "stub_xc_domain_setmaxmem"
external domain_set_memmap_limit: handle -> domid -> int64 -> unit
= "stub_xc_domain_set_memmap_limit"
= "stub_xc_domain_set_memmap_limit"
external domain_memory_increase_reservation: handle -> domid -> int64 -> unit
= "stub_xc_domain_memory_increase_reservation"
= "stub_xc_domain_memory_increase_reservation"
external map_foreign_range: handle -> domid -> int
-> nativeint -> Xenmmap.mmap_interface
= "stub_map_foreign_range"
-> nativeint -> Xenmmap.mmap_interface
= "stub_map_foreign_range"
type hvm_param =
| HVM_PARAM_CALLBACK_IRQ
@@ -357,15 +357,15 @@ external hvm_param_set: handle -> domid -> hvm_param -> int64 -> unit
= "stub_xc_hvm_param_set"
external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit
= "stub_xc_domain_assign_device"
= "stub_xc_domain_assign_device"
external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit
= "stub_xc_domain_deassign_device"
= "stub_xc_domain_deassign_device"
external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool
= "stub_xc_domain_test_assign_device"
= "stub_xc_domain_test_assign_device"
external version: handle -> version = "stub_xc_version_version"
external version_compile_info: handle -> compile_info
= "stub_xc_version_compile_info"
= "stub_xc_version_compile_info"
external version_changeset: handle -> string = "stub_xc_version_changeset"
external version_capabilities: handle -> string =
"stub_xc_version_capabilities"
@@ -380,7 +380,7 @@ external watchdog : handle -> int -> int32 -> int
(**
Convert the given number of pages to an amount in KiB, rounded up.
*)
*)
external pages_to_kib : int64 -> int64 = "stub_pages_to_kib"
let pages_to_mib pages = Int64.div (pages_to_kib pages) 1024L
tools/ocaml/libs/xc/xenctrl.mli
+6 -6
View File
@@ -182,11 +182,11 @@ external domain_getinfo : handle -> domid -> domaininfo
external domain_get_vcpuinfo : handle -> int -> int -> vcpuinfo
= "stub_xc_vcpu_getinfo"
external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit
= "stub_xc_domain_ioport_permission"
= "stub_xc_domain_ioport_permission"
external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit
= "stub_xc_domain_iomem_permission"
= "stub_xc_domain_iomem_permission"
external domain_irq_permission: handle -> domid -> int -> bool -> unit
= "stub_xc_domain_irq_permission"
= "stub_xc_domain_irq_permission"
external vcpu_affinity_set : handle -> domid -> int -> bool array -> unit
= "stub_xc_vcpu_setaffinity"
external vcpu_affinity_get : handle -> domid -> int -> bool array
@@ -284,11 +284,11 @@ external hvm_param_set: handle -> domid -> hvm_param -> int64 -> unit
= "stub_xc_hvm_param_set"
external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit
= "stub_xc_domain_assign_device"
= "stub_xc_domain_assign_device"
external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit
= "stub_xc_domain_deassign_device"
= "stub_xc_domain_deassign_device"
external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool
= "stub_xc_domain_test_assign_device"
= "stub_xc_domain_test_assign_device"
external version : handle -> version = "stub_xc_version_version"
external version_compile_info : handle -> compile_info
tools/ocaml/libs/xs/queueop.ml
+24 -24
View File
@@ -18,8 +18,8 @@ open Xenbus
let data_concat ls = (String.concat "\000" ls) ^ "\000"
let queue con pkt = let r = Xb.queue con pkt in assert (r <> None)
let queue_path ty (tid: int) (path: string) con =
let data = data_concat [ path; ] in
queue con (Xb.Packet.create tid 0 ty data)
let data = data_concat [ path; ] in
queue con (Xb.Packet.create tid 0 ty data)
(* operations *)
let directory tid path con = queue_path Xb.Op.Directory tid path con
@@ -28,48 +28,48 @@ let read tid path con = queue_path Xb.Op.Read tid path con
let getperms tid path con = queue_path Xb.Op.Getperms tid path con
let debug commands con =
queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands))
queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands))
let watch path data con =
let data = data_concat [ path; data; ] in
queue con (Xb.Packet.create 0 0 Xb.Op.Watch data)
let data = data_concat [ path; data; ] in
queue con (Xb.Packet.create 0 0 Xb.Op.Watch data)
let unwatch path data con =
let data = data_concat [ path; data; ] in
queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data)
let data = data_concat [ path; data; ] in
queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data)
let transaction_start con =
queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat []))
queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat []))
let transaction_end tid commit con =
let data = data_concat [ (if commit then "T" else "F"); ] in
queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data)
let data = data_concat [ (if commit then "T" else "F"); ] in
queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data)
let introduce domid mfn port con =
let data = data_concat [ Printf.sprintf "%u" domid;
Printf.sprintf "%nu" mfn;
string_of_int port; ] in
queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data)
let data = data_concat [ Printf.sprintf "%u" domid;
Printf.sprintf "%nu" mfn;
string_of_int port; ] in
queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data)
let release domid con =
let data = data_concat [ Printf.sprintf "%u" domid; ] in
queue con (Xb.Packet.create 0 0 Xb.Op.Release data)
let data = data_concat [ Printf.sprintf "%u" domid; ] in
queue con (Xb.Packet.create 0 0 Xb.Op.Release data)
let resume domid con =
let data = data_concat [ Printf.sprintf "%u" domid; ] in
queue con (Xb.Packet.create 0 0 Xb.Op.Resume data)
let data = data_concat [ Printf.sprintf "%u" domid; ] in
queue con (Xb.Packet.create 0 0 Xb.Op.Resume data)
let getdomainpath domid con =
let data = data_concat [ Printf.sprintf "%u" domid; ] in
queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data)
let data = data_concat [ Printf.sprintf "%u" domid; ] in
queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data)
let write tid path value con =
let data = path ^ "\000" ^ value (* no NULL at the end *) in
queue con (Xb.Packet.create tid 0 Xb.Op.Write data)
let data = path ^ "\000" ^ value (* no NULL at the end *) in
queue con (Xb.Packet.create tid 0 Xb.Op.Write data)
let mkdir tid path con = queue_path Xb.Op.Mkdir tid path con
let rm tid path con = queue_path Xb.Op.Rm tid path con
let setperms tid path perms con =
let data = data_concat [ path; perms ] in
queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data)
let data = data_concat [ path; perms ] in
queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data)
tools/ocaml/libs/xs/xs.ml
+110 -110
View File
@@ -19,46 +19,46 @@ type con = Xsraw.con
type domid = int
type xsh =
{
con: con;
debug: string list -> string;
directory: string -> string list;
read: string -> string;
readv: string -> string list -> string list;
write: string -> string -> unit;
writev: string -> (string * string) list -> unit;
mkdir: string -> unit;
rm: string -> unit;
getperms: string -> perms;
setperms: string -> perms -> unit;
setpermsv: string -> string list -> perms -> unit;
introduce: domid -> nativeint -> int -> unit;
release: domid -> unit;
resume: domid -> unit;
getdomainpath: domid -> string;
watch: string -> string -> unit;
unwatch: string -> string -> unit;
}
{
con: con;
debug: string list -> string;
directory: string -> string list;
read: string -> string;
readv: string -> string list -> string list;
write: string -> string -> unit;
writev: string -> (string * string) list -> unit;
mkdir: string -> unit;
rm: string -> unit;
getperms: string -> perms;
setperms: string -> perms -> unit;
setpermsv: string -> string list -> perms -> unit;
introduce: domid -> nativeint -> int -> unit;
release: domid -> unit;
resume: domid -> unit;
getdomainpath: domid -> string;
watch: string -> string -> unit;
unwatch: string -> string -> unit;
}
let get_operations con = {
con = con;
debug = (fun commands -> Xsraw.debug commands con);
directory = (fun path -> Xsraw.directory 0 path con);
read = (fun path -> Xsraw.read 0 path con);
readv = (fun dir vec -> Xsraw.readv 0 dir vec con);
write = (fun path value -> Xsraw.write 0 path value con);
writev = (fun dir vec -> Xsraw.writev 0 dir vec con);
mkdir = (fun path -> Xsraw.mkdir 0 path con);
rm = (fun path -> Xsraw.rm 0 path con);
getperms = (fun path -> Xsraw.getperms 0 path con);
setperms = (fun path perms -> Xsraw.setperms 0 path perms con);
setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con);
introduce = (fun id mfn port -> Xsraw.introduce id mfn port con);
release = (fun id -> Xsraw.release id con);
resume = (fun id -> Xsraw.resume id con);
getdomainpath = (fun id -> Xsraw.getdomainpath id con);
watch = (fun path data -> Xsraw.watch path data con);
unwatch = (fun path data -> Xsraw.unwatch path data con);
con = con;
debug = (fun commands -> Xsraw.debug commands con);
directory = (fun path -> Xsraw.directory 0 path con);
read = (fun path -> Xsraw.read 0 path con);
readv = (fun dir vec -> Xsraw.readv 0 dir vec con);
write = (fun path value -> Xsraw.write 0 path value con);
writev = (fun dir vec -> Xsraw.writev 0 dir vec con);
mkdir = (fun path -> Xsraw.mkdir 0 path con);
rm = (fun path -> Xsraw.rm 0 path con);
getperms = (fun path -> Xsraw.getperms 0 path con);
setperms = (fun path perms -> Xsraw.setperms 0 path perms con);
setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con);
introduce = (fun id mfn port -> Xsraw.introduce id mfn port con);
release = (fun id -> Xsraw.release id con);
resume = (fun id -> Xsraw.resume id con);
getdomainpath = (fun id -> Xsraw.getdomainpath id con);
watch = (fun path data -> Xsraw.watch path data con);
unwatch = (fun path data -> Xsraw.unwatch path data con);
}
let transaction xsh = Xst.transaction xsh.con
@@ -81,71 +81,71 @@ exception Timeout_with_nonempty_queue
let max_blocking_time = 5. (* seconds *)
let read_watchevent_timeout xsh timeout callback =
let start_time = Unix.gettimeofday () in
let end_time = start_time +. timeout in
let start_time = Unix.gettimeofday () in
let end_time = start_time +. timeout in
let left = ref timeout in
let left = ref timeout in
(* Returns true if a watch event in the queue satisfied us *)
let process_queued_events () =
let success = ref false in
while Xsraw.has_watchevents xsh.con && not(!success)
do
success := callback (Xsraw.get_watchevent xsh.con)
done;
!success in
(* Returns true if a watch event read from the socket satisfied us *)
let process_incoming_event () =
let fd = get_fd xsh in
let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time !left) in
(* Returns true if a watch event in the queue satisfied us *)
let process_queued_events () =
let success = ref false in
while Xsraw.has_watchevents xsh.con && not(!success)
do
success := callback (Xsraw.get_watchevent xsh.con)
done;
!success in
(* Returns true if a watch event read from the socket satisfied us *)
let process_incoming_event () =
let fd = get_fd xsh in
let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time !left) in
(* If data is available for reading then read it *)
if r = []
then false (* timeout, either a max_blocking_time or global *)
else callback (Xsraw.read_watchevent xsh.con) in
(* If data is available for reading then read it *)
if r = []
then false (* timeout, either a max_blocking_time or global *)
else callback (Xsraw.read_watchevent xsh.con) in
let success = ref false in
while !left > 0. && not(!success)
do
(* NB the 'callback' might call back into Xs functions
and as a side-effect, watches might be queued. Hence
we must process the queue on every loop iteration *)
let success = ref false in
while !left > 0. && not(!success)
do
(* NB the 'callback' might call back into Xs functions
and as a side-effect, watches might be queued. Hence
we must process the queue on every loop iteration *)
(* First process all queued watch events *)
if not(!success)
then success := process_queued_events ();
(* Then block for one more watch event *)
if not(!success)
then success := process_incoming_event ();
(* Just in case our callback caused events to be queued
and this is our last time round the loop: this prevents
us throwing the Timeout_with_nonempty_queue spuriously *)
if not(!success)
then success := process_queued_events ();
(* First process all queued watch events *)
if not(!success)
then success := process_queued_events ();
(* Then block for one more watch event *)
if not(!success)
then success := process_incoming_event ();
(* Just in case our callback caused events to be queued
and this is our last time round the loop: this prevents
us throwing the Timeout_with_nonempty_queue spuriously *)
if not(!success)
then success := process_queued_events ();
(* Update the time left *)
let current_time = Unix.gettimeofday () in
left := end_time -. current_time
done;
if not(!success) then begin
(* Sanity check: it should be impossible for any
events to be queued here *)
if Xsraw.has_watchevents xsh.con
then raise Timeout_with_nonempty_queue
else raise Timeout
end
(* Update the time left *)
let current_time = Unix.gettimeofday () in
left := end_time -. current_time
done;
if not(!success) then begin
(* Sanity check: it should be impossible for any
events to be queued here *)
if Xsraw.has_watchevents xsh.con
then raise Timeout_with_nonempty_queue
else raise Timeout
end
let monitor_paths xsh l time callback =
let unwatch () =
List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in
List.iter (fun (w,v) -> xsh.watch w v) l;
begin try
read_watchevent_timeout xsh time callback;
with
exn -> unwatch (); raise exn;
end;
unwatch ()
let unwatch () =
List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in
List.iter (fun (w,v) -> xsh.watch w v) l;
begin try
read_watchevent_timeout xsh time callback;
with
exn -> unwatch (); raise exn;
end;
unwatch ()
let daemon_socket = Paths.xen_run_stored ^ "/socket"
@@ -153,24 +153,24 @@ let daemon_socket = Paths.xen_run_stored ^ "/socket"
exception Failed_to_connect
let daemon_open () =
try
let sockaddr = Unix.ADDR_UNIX(daemon_socket) in
let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
Unix.connect sock sockaddr;
Unix.set_close_on_exec sock;
make sock
with _ -> raise Failed_to_connect
try
let sockaddr = Unix.ADDR_UNIX(daemon_socket) in
let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
Unix.connect sock sockaddr;
Unix.set_close_on_exec sock;
make sock
with _ -> raise Failed_to_connect
let domain_open () =
let path = try
let devpath = "/dev/xen/xenbus" in
Unix.access devpath [ Unix.F_OK ];
devpath
with Unix.Unix_error(_, _, _) ->
"/proc/xen/xenbus" in
let path = try
let devpath = "/dev/xen/xenbus" in
Unix.access devpath [ Unix.F_OK ];
devpath
with Unix.Unix_error(_, _, _) ->
"/proc/xen/xenbus" in
let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in
Unix.set_close_on_exec fd;
make fd
let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in
Unix.set_close_on_exec fd;
make fd
let close xsh = Xsraw.close xsh.con
tools/ocaml/libs/xs/xs.mli
+23 -23
View File
@@ -23,31 +23,31 @@ exception Failed_to_connect
- owner domid.
- other perm: applied to domain that is not owner or in ACL.
- ACL: list of per-domain permission
*)
*)
type perms = Xsraw.perms
type domid = int
type con
type xsh = {
con : con;
debug: string list -> string;
directory : string -> string list;
read : string -> string;
readv : string -> string list -> string list;
write : string -> string -> unit;
writev : string -> (string * string) list -> unit;
mkdir : string -> unit;
rm : string -> unit;
getperms : string -> perms;
setperms : string -> perms -> unit;
setpermsv : string -> string list -> perms -> unit;
introduce : domid -> nativeint -> int -> unit;
release : domid -> unit;
resume : domid -> unit;
getdomainpath : domid -> string;
watch : string -> string -> unit;
unwatch : string -> string -> unit;
con : con;
debug: string list -> string;
directory : string -> string list;
read : string -> string;
readv : string -> string list -> string list;
write : string -> string -> unit;
writev : string -> (string * string) list -> unit;
mkdir : string -> unit;
rm : string -> unit;
getperms : string -> perms;
setperms : string -> perms -> unit;
setpermsv : string -> string list -> perms -> unit;
introduce : domid -> nativeint -> int -> unit;
release : domid -> unit;
resume : domid -> unit;
getdomainpath : domid -> string;
watch : string -> string -> unit;
unwatch : string -> string -> unit;
}
(** get operations provide a vector of xenstore function that apply to one
@@ -75,10 +75,10 @@ val read_watchevent_timeout : xsh -> float -> (string * string -> bool) -> unit
(** register a set of watches, then wait for watchevent.
remove all watches previously set before giving back the hand. *)
val monitor_paths : xsh
-> (string * string) list
-> float
-> (string * string -> bool)
-> unit
-> (string * string) list
-> float
-> (string * string -> bool)
-> unit
(** open a socket-based xenstored connection *)
val daemon_open : unit -> xsh
tools/ocaml/libs/xs/xsraw.ml
+150 -150
View File
@@ -23,239 +23,239 @@ exception Unexpected_packet of string
exception Invalid_path of string
let unexpected_packet expected received =
let s = Printf.sprintf "expecting %s received %s"
(Xb.Op.to_string expected)
(Xb.Op.to_string received) in
raise (Unexpected_packet s)
let s = Printf.sprintf "expecting %s received %s"
(Xb.Op.to_string expected)
(Xb.Op.to_string received) in
raise (Unexpected_packet s)
type con = {
xb: Xenbus.Xb.t;
watchevents: (string * string) Queue.t;
xb: Xenbus.Xb.t;
watchevents: (string * string) Queue.t;
}
let close con =
Xb.close con.xb
Xb.close con.xb
let capacity = { Xb.maxoutstanding = 1; maxwatchevents = 0; }
let open_fd fd = {
xb = Xb.open_fd ~capacity fd;
watchevents = Queue.create ();
xb = Xb.open_fd ~capacity fd;
watchevents = Queue.create ();
}
let rec split_string ?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_string ~limit: nlimit c b)
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_string ~limit: nlimit c b)
type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR
type perms = int * perm * (int * perm) list
let string_of_perms perms =
let owner, other, acl = perms in
let char_of_perm perm =
match perm with PERM_NONE -> 'n' | PERM_READ -> 'r'
| PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in
let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm perm) id in
String.concat "\000" (List.map string_of_perm ((owner,other) :: acl))
let owner, other, acl = perms in
let char_of_perm perm =
match perm with PERM_NONE -> 'n' | PERM_READ -> 'r'
| PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in
let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm perm) id in
String.concat "\000" (List.map string_of_perm ((owner,other) :: acl))
let perms_of_string s =
let perm_of_char c =
match c with 'n' -> PERM_NONE | 'r' -> PERM_READ
| 'w' -> PERM_WRITE | 'b' -> PERM_RDWR
| c -> invalid_arg (Printf.sprintf "unknown permission type: %c" c) in
let perm_of_string s =
if String.length s < 2
then invalid_arg (Printf.sprintf "perm of string: length = %d; contents=\"%s\"" (String.length s) s)
else
begin
int_of_string (String.sub s 1 (String.length s - 1)),
perm_of_char s.[0]
end in
let rec split s =
try let i = String.index s '\000' in
String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 - i))
with Not_found -> if s = "" then [] else [ s ] in
let l = List.map perm_of_string (split s) in
match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, [])
let perm_of_char c =
match c with 'n' -> PERM_NONE | 'r' -> PERM_READ
| 'w' -> PERM_WRITE | 'b' -> PERM_RDWR
| c -> invalid_arg (Printf.sprintf "unknown permission type: %c" c) in
let perm_of_string s =
if String.length s < 2
then invalid_arg (Printf.sprintf "perm of string: length = %d; contents=\"%s\"" (String.length s) s)
else
begin
int_of_string (String.sub s 1 (String.length s - 1)),
perm_of_char s.[0]
end in
let rec split s =
try let i = String.index s '\000' in
String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 - i))
with Not_found -> if s = "" then [] else [ s ] in
let l = List.map perm_of_string (split s) in
match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, [])
(* send one packet - can sleep *)
let pkt_send con =
if Xb.has_old_output con.xb then
raise Partial_not_empty;
let workdone = ref false in
while not !workdone
do
workdone := Xb.output con.xb
done
if Xb.has_old_output con.xb then
raise Partial_not_empty;
let workdone = ref false in
while not !workdone
do
workdone := Xb.output con.xb
done
(* receive one packet - can sleep *)
let rec pkt_recv con =
match Xb.input con.xb with
| Some packet -> packet
| None -> pkt_recv con
match Xb.input con.xb with
| Some packet -> packet
| None -> pkt_recv con
let pkt_recv_timeout con timeout =
let fd = Xb.get_fd con.xb in
let r, _, _ = Unix.select [ fd ] [] [] timeout in
if r = [] then
true, None
else
false, Xb.input con.xb
let fd = Xb.get_fd con.xb in
let r, _, _ = Unix.select [ fd ] [] [] timeout in
if r = [] then
true, None
else
false, Xb.input con.xb
let queue_watchevent con data =
let ls = split_string ~limit:2 '\000' data in
if List.length ls != 2 then
raise (Xb.Packet.DataError "arguments number mismatch");
let event = List.nth ls 0
and event_data = List.nth ls 1 in
Queue.push (event, event_data) con.watchevents
let ls = split_string ~limit:2 '\000' data in
if List.length ls != 2 then
raise (Xb.Packet.DataError "arguments number mismatch");
let event = List.nth ls 0
and event_data = List.nth ls 1 in
Queue.push (event, event_data) con.watchevents
let has_watchevents con = Queue.length con.watchevents > 0
let get_watchevent con = Queue.pop con.watchevents
let read_watchevent con =
let pkt = pkt_recv con in
match Xb.Packet.get_ty pkt with
| Xb.Op.Watchevent ->
queue_watchevent con (Xb.Packet.get_data pkt);
Queue.pop con.watchevents
| ty -> unexpected_packet Xb.Op.Watchevent ty
let pkt = pkt_recv con in
match Xb.Packet.get_ty pkt with
| Xb.Op.Watchevent ->
queue_watchevent con (Xb.Packet.get_data pkt);
Queue.pop con.watchevents
| ty -> unexpected_packet Xb.Op.Watchevent ty
(* send one packet in the queue, and wait for reply *)
let rec sync_recv ty con =
let pkt = pkt_recv con in
match Xb.Packet.get_ty pkt with
| Xb.Op.Error -> (
match Xb.Packet.get_data pkt with
| "ENOENT" -> raise Xb.Noent
| "EAGAIN" -> raise Xb.Eagain
| "EINVAL" -> raise Xb.Invalid
| s -> raise (Xb.Packet.Error s))
| Xb.Op.Watchevent ->
queue_watchevent con (Xb.Packet.get_data pkt);
sync_recv ty con
| rty when rty = ty -> Xb.Packet.get_data pkt
| rty -> unexpected_packet ty rty
let pkt = pkt_recv con in
match Xb.Packet.get_ty pkt with
| Xb.Op.Error -> (
match Xb.Packet.get_data pkt with
| "ENOENT" -> raise Xb.Noent
| "EAGAIN" -> raise Xb.Eagain
| "EINVAL" -> raise Xb.Invalid
| s -> raise (Xb.Packet.Error s))
| Xb.Op.Watchevent ->
queue_watchevent con (Xb.Packet.get_data pkt);
sync_recv ty con
| rty when rty = ty -> Xb.Packet.get_data pkt
| rty -> unexpected_packet ty rty
let sync f con =
(* queue a query using function f *)
f con.xb;
if Xb.output_len con.xb = 0 then
Printf.printf "output len = 0\n%!";
let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in
pkt_send con;
sync_recv ty con
(* queue a query using function f *)
f con.xb;
if Xb.output_len con.xb = 0 then
Printf.printf "output len = 0\n%!";
let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in
pkt_send con;
sync_recv ty con
let ack s =
if s = "OK" then () else raise (Xb.Packet.DataError s)
if s = "OK" then () else raise (Xb.Packet.DataError s)
(** Check paths are suitable for read/write/mkdir/rm/directory etc (NOT watches) *)
let validate_path path =
(* Paths shouldn't have a "//" in the middle *)
let bad = "//" in
for offset = 0 to String.length path - (String.length bad) do
if String.sub path offset (String.length bad) = bad then
raise (Invalid_path path)
done;
(* Paths shouldn't have a "/" at the end, except for the root *)
if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then
raise (Invalid_path path)
(* Paths shouldn't have a "//" in the middle *)
let bad = "//" in
for offset = 0 to String.length path - (String.length bad) do
if String.sub path offset (String.length bad) = bad then
raise (Invalid_path path)
done;
(* Paths shouldn't have a "/" at the end, except for the root *)
if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then
raise (Invalid_path path)
(** Check to see if a path is suitable for watches *)
let validate_watch_path path =
(* Check for stuff like @releaseDomain etc first *)
if path <> "" && path.[0] = '@' then ()
else validate_path path
(* Check for stuff like @releaseDomain etc first *)
if path <> "" && path.[0] = '@' then ()
else validate_path path
let debug command con =
sync (Queueop.debug command) con
sync (Queueop.debug command) con
let directory tid path con =
validate_path path;
let data = sync (Queueop.directory tid path) con in
split_string '\000' data
validate_path path;
let data = sync (Queueop.directory tid path) con in
split_string '\000' data
let read tid path con =
validate_path path;
sync (Queueop.read tid path) con
validate_path path;
sync (Queueop.read tid path) con
let readv tid dir vec con =
List.map (fun path -> validate_path path; read tid path con)
(if dir <> "" then
(List.map (fun v -> dir ^ "/" ^ v) vec) else vec)
List.map (fun path -> validate_path path; read tid path con)
(if dir <> "" then
(List.map (fun v -> dir ^ "/" ^ v) vec) else vec)
let getperms tid path con =
validate_path path;
perms_of_string (sync (Queueop.getperms tid path) con)
validate_path path;
perms_of_string (sync (Queueop.getperms tid path) con)
let watch path data con =
validate_watch_path path;
ack (sync (Queueop.watch path data) con)
validate_watch_path path;
ack (sync (Queueop.watch path data) con)
let unwatch path data con =
validate_watch_path path;
ack (sync (Queueop.unwatch path data) con)
validate_watch_path path;
ack (sync (Queueop.unwatch path data) con)
let transaction_start con =
let data = sync (Queueop.transaction_start) con in
try
int_of_string data
with
_ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" data))
let data = sync (Queueop.transaction_start) con in
try
int_of_string data
with
_ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" data))
let transaction_end tid commit con =
try
ack (sync (Queueop.transaction_end tid commit) con);
true
with
Xb.Eagain -> false
try
ack (sync (Queueop.transaction_end tid commit) con);
true
with
Xb.Eagain -> false
let introduce domid mfn port con =
ack (sync (Queueop.introduce domid mfn port) con)
ack (sync (Queueop.introduce domid mfn port) con)
let release domid con =
ack (sync (Queueop.release domid) con)
ack (sync (Queueop.release domid) con)
let resume domid con =
ack (sync (Queueop.resume domid) con)
ack (sync (Queueop.resume domid) con)
let getdomainpath domid con =
sync (Queueop.getdomainpath domid) con
sync (Queueop.getdomainpath domid) con
let write tid path value con =
validate_path path;
ack (sync (Queueop.write tid path value) con)
validate_path path;
ack (sync (Queueop.write tid path value) con)
let writev tid dir vec con =
List.iter (fun (entry, value) ->
let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
validate_path path;
write tid path value con) vec
List.iter (fun (entry, value) ->
let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
validate_path path;
write tid path value con) vec
let mkdir tid path con =
validate_path path;
ack (sync (Queueop.mkdir tid path) con)
validate_path path;
ack (sync (Queueop.mkdir tid path) con)
let rm tid path con =
validate_path path;
try
ack (sync (Queueop.rm tid path) con)
with
Xb.Noent -> ()
validate_path path;
try
ack (sync (Queueop.rm tid path) con)
with
Xb.Noent -> ()
let setperms tid path perms con =
validate_path path;
ack (sync (Queueop.setperms tid path (string_of_perms perms)) con)
validate_path path;
ack (sync (Queueop.setperms tid path (string_of_perms perms)) con)
let setpermsv tid dir vec perms con =
List.iter (fun entry ->
let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
validate_path path;
setperms tid path perms con) vec
List.iter (fun entry ->
let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
validate_path path;
setperms tid path perms con) vec
tools/ocaml/libs/xs/xst.ml
+38 -38
View File
@@ -15,47 +15,47 @@
*)
type ops =
{
directory: string -> string list;
read: string -> string;
readv: string -> string list -> string list;
write: string -> string -> unit;
writev: string -> (string * string) list -> unit;
mkdir: string -> unit;
rm: string -> unit;
getperms: string -> Xsraw.perms;
setperms: string -> Xsraw.perms -> unit;
setpermsv: string -> string list -> Xsraw.perms -> unit;
}
{
directory: string -> string list;
read: string -> string;
readv: string -> string list -> string list;
write: string -> string -> unit;
writev: string -> (string * string) list -> unit;
mkdir: string -> unit;
rm: string -> unit;
getperms: string -> Xsraw.perms;
setperms: string -> Xsraw.perms -> unit;
setpermsv: string -> string list -> Xsraw.perms -> unit;
}
let get_operations tid xsh = {
directory = (fun path -> Xsraw.directory tid path xsh);
read = (fun path -> Xsraw.read tid path xsh);
readv = (fun dir vec -> Xsraw.readv tid dir vec xsh);
write = (fun path value -> Xsraw.write tid path value xsh);
writev = (fun dir vec -> Xsraw.writev tid dir vec xsh);
mkdir = (fun path -> Xsraw.mkdir tid path xsh);
rm = (fun path -> Xsraw.rm tid path xsh);
getperms = (fun path -> Xsraw.getperms tid path xsh);
setperms = (fun path perms -> Xsraw.setperms tid path perms xsh);
setpermsv = (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xsh);
directory = (fun path -> Xsraw.directory tid path xsh);
read = (fun path -> Xsraw.read tid path xsh);
readv = (fun dir vec -> Xsraw.readv tid dir vec xsh);
write = (fun path value -> Xsraw.write tid path value xsh);
writev = (fun dir vec -> Xsraw.writev tid dir vec xsh);
mkdir = (fun path -> Xsraw.mkdir tid path xsh);
rm = (fun path -> Xsraw.rm tid path xsh);
getperms = (fun path -> Xsraw.getperms tid path xsh);
setperms = (fun path perms -> Xsraw.setperms tid path perms xsh);
setpermsv = (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xsh);
}
let transaction xsh (f: ops -> 'a) : 'a =
let commited = ref false and result = ref None in
while not !commited
do
let tid = Xsraw.transaction_start xsh in
let t = get_operations tid xsh in
let commited = ref false and result = ref None in
while not !commited
do
let tid = Xsraw.transaction_start xsh in
let t = get_operations tid xsh in
begin try
result := Some (f t)
with exn ->
ignore (Xsraw.transaction_end tid false xsh);
raise exn
end;
commited := Xsraw.transaction_end tid true xsh
done;
match !result with
| None -> failwith "internal error in transaction"
| Some result -> result
begin try
result := Some (f t)
with exn ->
ignore (Xsraw.transaction_end tid false xsh);
raise exn
end;
commited := Xsraw.transaction_end tid true xsh
done;
match !result with
| None -> failwith "internal error in transaction"
| Some result -> result
tools/ocaml/libs/xs/xst.mli
+10 -10
View File
@@ -14,16 +14,16 @@
* GNU Lesser General Public License for more details.
*)
type ops = {
directory : string -> string list;
read : string -> string;
readv : string -> string list -> string list;
write : string -> string -> unit;
writev : string -> (string * string) list -> unit;
mkdir : string -> unit;
rm : string -> unit;
getperms : string -> Xsraw.perms;
setperms : string -> Xsraw.perms -> unit;
setpermsv : string -> string list -> Xsraw.perms -> unit;
directory : string -> string list;
read : string -> string;
readv : string -> string list -> string list;
write : string -> string -> unit;
writev : string -> (string * string) list -> unit;
mkdir : string -> unit;
rm : string -> unit;
getperms : string -> Xsraw.perms;
setperms : string -> Xsraw.perms -> unit;
setpermsv : string -> string list -> Xsraw.perms -> unit;
}
val get_operations : int -> Xsraw.con -> ops
tools/ocaml/test/dmesg.ml
+13 -13
View File
@@ -1,17 +1,17 @@
let _ =
Xenlight.register_exceptions ();
let logger = Xtl.create_stdio_logger ~level:Xentoollog.Debug () in
let ctx = Xenlight.ctx_alloc logger in
Xenlight.register_exceptions ();
let logger = Xtl.create_stdio_logger ~level:Xentoollog.Debug () in
let ctx = Xenlight.ctx_alloc logger in
let open Xenlight.Host in
let reader = xen_console_read_start ctx 0 in
(try
while true do
let line = xen_console_read_line ctx reader in
print_string line
done
with End_of_file -> ());
let _ = xen_console_read_finish ctx reader in
()
let open Xenlight.Host in
let reader = xen_console_read_start ctx 0 in
(try
while true do
let line = xen_console_read_line ctx reader in
print_string line
done
with End_of_file -> ());
let _ = xen_console_read_finish ctx reader in
()
tools/ocaml/test/list_domains.ml
+2 -2
View File
@@ -20,7 +20,7 @@ let _ =
let domains = Xenlight.Dominfo.list ctx in
List.iter (fun d -> print_dominfo d) domains
with Xenlight.Error(err, fn) -> begin
printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
end
printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
end
tools/ocaml/test/raise_exception.ml
+2 -2
View File
@@ -4,6 +4,6 @@ let _ =
try
Xenlight.test_raise_exception ()
with Xenlight.Error(err, fn) -> begin
printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
end
printf "Caught Exception: %s: %s\n" (Xenlight.string_of_error err) fn;
end
tools/ocaml/test/xtl.ml
+14 -14
View File
@@ -2,24 +2,24 @@ open Printf
open Xentoollog
let stdio_vmessage min_level level errno ctx msg =
let level_str = level_to_string level
and errno_str = match errno with None -> "" | Some s -> sprintf ": errno=%d" s
and ctx_str = match ctx with None -> "" | Some s -> sprintf ": %s" s in
if compare min_level level <= 0 then begin
printf "%s%s%s: %s\n" level_str ctx_str errno_str msg;
flush stdout;
end
let level_str = level_to_string level
and errno_str = match errno with None -> "" | Some s -> sprintf ": errno=%d" s
and ctx_str = match ctx with None -> "" | Some s -> sprintf ": %s" s in
if compare min_level level <= 0 then begin
printf "%s%s%s: %s\n" level_str ctx_str errno_str msg;
flush stdout;
end
let stdio_progress _ctx what percent dne total =
let nl = if dne = total then "\n" else "" in
printf "\rProgress %s %d%% (%Ld/%Ld)%s" what percent dne total nl;
flush stdout
let nl = if dne = total then "\n" else "" in
printf "\rProgress %s %d%% (%Ld/%Ld)%s" what percent dne total nl;
flush stdout
let create_stdio_logger ?(level=Info) () =
let cbs = {
vmessage = stdio_vmessage level;
progress = stdio_progress; } in
create "Xentoollog.stdio_logger" cbs
let cbs = {
vmessage = stdio_vmessage level;
progress = stdio_progress; } in
create "Xentoollog.stdio_logger" cbs
let do_test level =
let lgr = create_stdio_logger ~level:level () in
tools/ocaml/xenstored/config.ml
+78 -78
View File
@@ -15,98 +15,98 @@
*)
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)
| 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 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 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 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 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 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)
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
let cf = parse filename in
validate cf expected other
tools/ocaml/xenstored/connection.ml
+289 -289
View File
@@ -24,281 +24,281 @@ type 'a bounded_sender = 'a -> unit option
(** a bounded sender accepts an ['a] item and returns:
None - if there is no room to accept the item
Some () - if it has successfully accepted/sent the item
*)
*)
module BoundedPipe : sig
type 'a t
type 'a t
(** [create ~capacity ~destination] creates a bounded pipe with a
local buffer holding at most [capacity] items. Once the buffer is
full it will not accept further items. items from the pipe are
flushed into [destination] as long as it accepts items. The
destination could be another pipe.
*)
val create: capacity:int -> destination:'a bounded_sender -> 'a t
(** [create ~capacity ~destination] creates a bounded pipe with a
local buffer holding at most [capacity] items. Once the buffer is
full it will not accept further items. items from the pipe are
flushed into [destination] as long as it accepts items. The
destination could be another pipe.
*)
val create: capacity:int -> destination:'a bounded_sender -> 'a t
(** [is_empty t] returns whether the local buffer of [t] is empty. *)
val is_empty : _ t -> bool
(** [is_empty t] returns whether the local buffer of [t] is empty. *)
val is_empty : _ t -> bool
(** [length t] the number of items in the internal buffer *)
val length: _ t -> int
(** [length t] the number of items in the internal buffer *)
val length: _ t -> int
(** [flush_pipe t] sends as many items from the local buffer as possible,
which could be none. *)
val flush_pipe: _ t -> unit
(** [flush_pipe t] sends as many items from the local buffer as possible,
which could be none. *)
val flush_pipe: _ t -> unit
(** [push t item] tries to [flush_pipe] and then push [item]
into the pipe if its [capacity] allows.
Returns [None] if there is no more room
*)
val push : 'a t -> 'a bounded_sender
(** [push t item] tries to [flush_pipe] and then push [item]
into the pipe if its [capacity] allows.
Returns [None] if there is no more room
*)
val push : 'a t -> 'a bounded_sender
end = struct
(* items are enqueued in [q], and then flushed to [connect_to] *)
type 'a t =
{ q: 'a Queue.t
; destination: 'a bounded_sender
; capacity: int
}
(* items are enqueued in [q], and then flushed to [connect_to] *)
type 'a t =
{ q: 'a Queue.t
; destination: 'a bounded_sender
; capacity: int
}
let create ~capacity ~destination =
{ q = Queue.create (); capacity; destination }
let create ~capacity ~destination =
{ q = Queue.create (); capacity; destination }
let rec flush_pipe t =
if not Queue.(is_empty t.q) then
let item = Queue.peek t.q in
match t.destination item with
| None -> () (* no room *)
| Some () ->
(* successfully sent item to next stage *)
let _ = Queue.pop t.q in
(* continue trying to send more items *)
flush_pipe t
let rec flush_pipe t =
if not Queue.(is_empty t.q) then
let item = Queue.peek t.q in
match t.destination item with
| None -> () (* no room *)
| Some () ->
(* successfully sent item to next stage *)
let _ = Queue.pop t.q in
(* continue trying to send more items *)
flush_pipe t
let push t item =
(* first try to flush as many items from this pipe as possible to make room,
it is important to do this first to preserve the order of the items
*)
flush_pipe t;
if Queue.length t.q < t.capacity then begin
(* enqueue, instead of sending directly.
this ensures that [out] sees the items in the same order as we receive them
*)
Queue.push item t.q;
Some (flush_pipe t)
end else None
let push t item =
(* first try to flush as many items from this pipe as possible to make room,
it is important to do this first to preserve the order of the items
*)
flush_pipe t;
if Queue.length t.q < t.capacity then begin
(* enqueue, instead of sending directly.
this ensures that [out] sees the items in the same order as we receive them
*)
Queue.push item t.q;
Some (flush_pipe t)
end else None
let is_empty t = Queue.is_empty t.q
let length t = Queue.length t.q
let is_empty t = Queue.is_empty t.q
let length t = Queue.length t.q
end
type watch = {
con: t;
token: string;
path: string;
base: string;
is_relative: bool;
pending_watchevents: Xenbus.Xb.Packet.t BoundedPipe.t;
con: t;
token: string;
path: string;
base: string;
is_relative: bool;
pending_watchevents: Xenbus.Xb.Packet.t BoundedPipe.t;
}
and t = {
xb: Xenbus.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;
pending_source_watchevents: (watch * Xenbus.Xb.Packet.t) BoundedPipe.t
xb: Xenbus.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;
pending_source_watchevents: (watch * Xenbus.Xb.Packet.t) BoundedPipe.t
}
module Watch = struct
module T = struct
type t = watch
module T = struct
type t = watch
let compare w1 w2 =
(* cannot compare watches from different connections *)
assert (w1.con == w2.con);
match String.compare w1.token w2.token with
| 0 -> String.compare w1.path w2.path
| n -> n
end
module Set = Set.Make(T)
let compare w1 w2 =
(* cannot compare watches from different connections *)
assert (w1.con == w2.con);
match String.compare w1.token w2.token with
| 0 -> String.compare w1.path w2.path
| n -> n
end
module Set = Set.Make(T)
let flush_events t =
BoundedPipe.flush_pipe t.pending_watchevents;
not (BoundedPipe.is_empty t.pending_watchevents)
let flush_events t =
BoundedPipe.flush_pipe t.pending_watchevents;
not (BoundedPipe.is_empty t.pending_watchevents)
let pending_watchevents t =
BoundedPipe.length t.pending_watchevents
let pending_watchevents t =
BoundedPipe.length t.pending_watchevents
end
let source_flush_watchevents t =
BoundedPipe.flush_pipe t.pending_source_watchevents
BoundedPipe.flush_pipe t.pending_source_watchevents
let source_pending_watchevents t =
BoundedPipe.length t.pending_source_watchevents
BoundedPipe.length t.pending_source_watchevents
let mark_as_bad con =
match con.dom with
|None -> ()
| Some domain -> Domain.mark_as_bad domain
match con.dom with
|None -> ()
| Some domain -> Domain.mark_as_bad domain
let initial_next_tid = 1
let do_reconnect con =
Xenbus.Xb.reconnect con.xb;
(* dom is the same *)
Hashtbl.clear con.transactions;
con.next_tid <- initial_next_tid;
Hashtbl.clear con.watches;
(* anonid is the same *)
con.nb_watches <- 0;
con.stat_nb_ops <- 0;
(* perm is the same *)
()
Xenbus.Xb.reconnect con.xb;
(* dom is the same *)
Hashtbl.clear con.transactions;
con.next_tid <- initial_next_tid;
Hashtbl.clear con.watches;
(* anonid is the same *)
con.nb_watches <- 0;
con.stat_nb_ops <- 0;
(* perm is the same *)
()
let get_path con =
Printf.sprintf "/local/domain/%i/" (match con.dom with None -> 0 | Some d -> Domain.get_id d)
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] <> '@';
pending_watchevents = BoundedPipe.create ~capacity:!Define.maxwatchevents ~destination:(Xenbus.Xb.queue con.xb)
con = con;
token = token;
path = path;
base = get_path con;
is_relative = path.[0] <> '/' && path.[0] <> '@';
pending_watchevents = BoundedPipe.create ~capacity:!Define.maxwatchevents ~destination:(Xenbus.Xb.queue con.xb)
}
let get_con w = w.con
let number_of_transactions con =
Hashtbl.length con.transactions
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))
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 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 destination (watch, pkt) =
BoundedPipe.push watch.pending_watchevents pkt
in
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 = initial_next_tid;
watches = Hashtbl.create 8;
nb_watches = 0;
anonid = id;
stat_nb_ops = 0;
perm = make_perm dom;
let destination (watch, pkt) =
BoundedPipe.push watch.pending_watchevents pkt
in
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 = initial_next_tid;
watches = Hashtbl.create 8;
nb_watches = 0;
anonid = id;
stat_nb_ops = 0;
perm = make_perm dom;
(* the actual capacity will be lower, this is used as an overflow
buffer: anything that doesn't fit elsewhere gets put here, only
limited by the amount of watches that you can generate with a
single xenstore command (which is finite, although possibly very
large in theory for Dom0). Once the pipe here has any contents the
domain is blocked from sending more commands until it is empty
again though.
*)
pending_source_watchevents = BoundedPipe.create ~capacity:Sys.max_array_length ~destination
}
in
Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con);
con
(* the actual capacity will be lower, this is used as an overflow
buffer: anything that doesn't fit elsewhere gets put here, only
limited by the amount of watches that you can generate with a
single xenstore command (which is finite, although possibly very
large in theory for Dom0). Once the pipe here has any contents the
domain is blocked from sending more commands until it is empty
again though.
*)
pending_source_watchevents = BoundedPipe.create ~capacity:Sys.max_array_length ~destination
}
in
Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con);
con
let get_fd con = Xenbus.Xb.get_fd con.xb
let close con =
Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con);
Xenbus.Xb.close con.xb
Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con);
Xenbus.Xb.close con.xb
let get_perm con =
con.perm
con.perm
let set_target con target_domid =
con.perm <- Perms.Connection.set_target (get_perm con) ~perms:[Perms.READ; Perms.WRITE] target_domid
con.perm <- Perms.Connection.set_target (get_perm con) ~perms:[Perms.READ; Perms.WRITE] target_domid
let is_backend_mmap con = Xenbus.Xb.is_mmap con.xb
let packet_of con tid rid ty data =
if (String.length data) > xenstore_payload_max && (is_backend_mmap con) then
Xenbus.Xb.Packet.create tid rid Xenbus.Xb.Op.Error "E2BIG\000"
else
Xenbus.Xb.Packet.create tid rid ty data
if (String.length data) > xenstore_payload_max && (is_backend_mmap con) then
Xenbus.Xb.Packet.create tid rid Xenbus.Xb.Op.Error "E2BIG\000"
else
Xenbus.Xb.Packet.create tid rid ty data
let send_reply con tid rid ty data =
let result = Xenbus.Xb.queue con.xb (packet_of con tid rid ty data) in
(* should never happen: we only process an input packet when there is room for an output packet *)
(* and the limit for replies is different from the limit for watch events *)
assert (result <> None)
let result = Xenbus.Xb.queue con.xb (packet_of con tid rid ty data) in
(* should never happen: we only process an input packet when there is room for an output packet *)
(* and the limit for replies is different from the limit for watch events *)
assert (result <> None)
let send_error con tid rid err = send_reply con tid rid Xenbus.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
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 []
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 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)
Perms.Connection.is_dom0 (get_perm con)
let add_watch con (path, apath) token =
if !Quota.activate && !Define.maxwatch > 0 &&
not (is_dom0 con) && con.nb_watches > !Define.maxwatch then
raise Quota.Limit_reached;
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;
watch
if !Quota.activate && !Define.maxwatch > 0 &&
not (is_dom0 con) && con.nb_watches > !Define.maxwatch then
raise Quota.Limit_reached;
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;
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 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 del_watches con =
Hashtbl.reset con.watches;
@@ -308,63 +308,63 @@ let del_transactions con =
Hashtbl.reset con.transactions
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 ll = Hashtbl.fold
(fun _ watches acc -> List.map (fun watch -> watch.path, watch.token) watches :: acc)
con.watches [] in
List.concat ll
let dbg fmt = Logging.debug "connection" fmt
let info fmt = Logging.info "connection" fmt
let lookup_watch_perm path = function
| None -> []
| Some root ->
try Store.Path.apply root path @@ fun parent name ->
Store.Node.get_perms parent ::
try [Store.Node.get_perms (Store.Node.find parent name)]
with Not_found -> []
with Define.Invalid_path | Not_found -> []
| None -> []
| Some root ->
try Store.Path.apply root path @@ fun parent name ->
Store.Node.get_perms parent ::
try [Store.Node.get_perms (Store.Node.find parent name)]
with Not_found -> []
with Define.Invalid_path | Not_found -> []
let lookup_watch_perms oldroot root path =
lookup_watch_perm path oldroot @ lookup_watch_perm path (Some root)
lookup_watch_perm path oldroot @ lookup_watch_perm path (Some root)
let fire_single_watch_unchecked source watch =
let data = Utils.join_by_null [watch.path; watch.token; ""] in
let pkt = packet_of watch.con Transaction.none 0 Xenbus.Xb.Op.Watchevent data in
let data = Utils.join_by_null [watch.path; watch.token; ""] in
let pkt = packet_of watch.con Transaction.none 0 Xenbus.Xb.Op.Watchevent data in
match BoundedPipe.push source.pending_source_watchevents (watch, pkt) with
| Some () -> () (* packet queued *)
| None ->
(* a well behaved Dom0 shouldn't be able to trigger this,
if it happens it is likely a Dom0 bug causing runaway memory usage
*)
failwith "watch event overflow, cannot happen"
match BoundedPipe.push source.pending_source_watchevents (watch, pkt) with
| Some () -> () (* packet queued *)
| None ->
(* a well behaved Dom0 shouldn't be able to trigger this,
if it happens it is likely a Dom0 bug causing runaway memory usage
*)
failwith "watch event overflow, cannot happen"
let fire_single_watch source (oldroot, root) watch =
let abspath = get_watch_path watch.con watch.path |> Store.Path.of_string in
let perms = lookup_watch_perms oldroot root abspath in
if Perms.can_fire_watch watch.con.perm perms then
fire_single_watch_unchecked source watch
else
let perms = perms |> List.map (Perms.Node.to_string ~sep:" ") |> String.concat ", " in
let con = get_domstr watch.con in
Logging.watch_not_fired ~con perms (Store.Path.to_string abspath)
let abspath = get_watch_path watch.con watch.path |> Store.Path.of_string in
let perms = lookup_watch_perms oldroot root abspath in
if Perms.can_fire_watch watch.con.perm perms then
fire_single_watch_unchecked source watch
else
let perms = perms |> List.map (Perms.Node.to_string ~sep:" ") |> String.concat ", " in
let con = get_domstr watch.con in
Logging.watch_not_fired ~con perms (Store.Path.to_string abspath)
let fire_watch source roots 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
fire_single_watch source roots { watch with path = new_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
fire_single_watch source roots { watch with path = new_path }
(* Search for a valid unused transaction id. *)
let rec valid_transaction_id con proposed_id =
(*
(*
* Clip proposed_id to the range [1, 0x3ffffffe]
*
* The chosen id must not trucate when written into the uint32_t tx_id
@@ -373,36 +373,36 @@ let rec valid_transaction_id con proposed_id =
*
* Oxenstored therefore supports only 1 billion open transactions.
*)
let id = if proposed_id <= 0 || proposed_id >= 0x3fffffff then 1 else proposed_id in
let id = if proposed_id <= 0 || proposed_id >= 0x3fffffff then 1 else proposed_id in
if Hashtbl.mem con.transactions id then (
(* Outstanding transaction with this id. Try the next. *)
valid_transaction_id con (id + 1)
) else
id
if Hashtbl.mem con.transactions id then (
(* Outstanding transaction with this id. Try the next. *)
valid_transaction_id con (id + 1)
) else
id
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 = valid_transaction_id con con.next_tid in
con.next_tid <- id + 1;
let ntrans = Transaction.make id store in
Hashtbl.add con.transactions id ntrans;
Logging.start_transaction ~tid:id ~con:(get_domstr con);
id
if !Define.maxtransaction > 0 && not (is_dom0 con)
&& Hashtbl.length con.transactions > !Define.maxtransaction then
raise Quota.Transaction_opened;
let id = valid_transaction_id con con.next_tid in
con.next_tid <- id + 1;
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);
match commit with
| None -> true
| Some transaction_replay_f ->
Transaction.commit ~con:(get_domstr con) trans || transaction_replay_f con trans
let trans = Hashtbl.find con.transactions tid in
Hashtbl.remove con.transactions tid;
Logging.end_transaction ~tid ~con:(get_domstr con);
match commit with
| None -> true
| Some transaction_replay_f ->
Transaction.commit ~con:(get_domstr con) trans || transaction_replay_f con trans
let get_transaction con tid =
Hashtbl.find con.transactions tid
Hashtbl.find con.transactions tid
let do_input con = Xenbus.Xb.input con.xb
let has_partial_input con = Xenbus.Xb.has_partial_input con.xb
@@ -434,53 +434,53 @@ let is_bad con = match con.dom with None -> false | Some dom -> Domain.is_bad_do
Restrictions below can be relaxed once xenstored learns to dump more
of its live state in a safe way *)
let has_extra_connection_data con =
let has_in = has_partial_input con in
let has_out = has_output con in
let has_nondefault_perms = make_perm con.dom <> con.perm in
has_in || has_out
(* TODO: what about SIGTERM, should use systemd to store FDS
|| has_socket (* dom0 sockets not * dumped yet *) *)
|| has_nondefault_perms (* set_target not dumped yet *)
let has_in = has_partial_input con in
let has_out = has_output con in
let has_nondefault_perms = make_perm con.dom <> con.perm in
has_in || has_out
(* TODO: what about SIGTERM, should use systemd to store FDS
|| has_socket (* dom0 sockets not * dumped yet *) *)
|| has_nondefault_perms (* set_target not dumped yet *)
let has_transaction_data con =
let n = number_of_transactions con in
dbg "%s: number of transactions = %d" (get_domstr con) n;
n > 0
let n = number_of_transactions con in
dbg "%s: number of transactions = %d" (get_domstr con) n;
n > 0
let prevents_live_update con = not (is_bad con)
&& (has_extra_connection_data con || has_transaction_data con)
&& (has_extra_connection_data con || has_transaction_data con)
let has_more_work con =
(has_more_input con && can_input con) || not (has_old_output con) && has_new_output con
(has_more_input con && can_input con) || not (has_old_output con) && has_new_output con
let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
let stats con =
Hashtbl.length con.watches, con.stat_nb_ops
Hashtbl.length con.watches, con.stat_nb_ops
let dump con chan =
let id = match con.dom with
| Some dom ->
let domid = Domain.get_id dom in
(* dump domain *)
Domain.dump dom chan;
domid
| None ->
let fd = con |> get_fd |> Utils.FD.to_int in
Printf.fprintf chan "socket,%d\n" fd;
-fd
in
(* dump watches *)
List.iter (fun (path, token) ->
Printf.fprintf chan "watch,%d,%s,%s\n" id (Utils.hexify path) (Utils.hexify token)
) (list_watches con)
let id = match con.dom with
| Some dom ->
let domid = Domain.get_id dom in
(* dump domain *)
Domain.dump dom chan;
domid
| None ->
let fd = con |> get_fd |> Utils.FD.to_int in
Printf.fprintf chan "socket,%d\n" fd;
-fd
in
(* dump watches *)
List.iter (fun (path, token) ->
Printf.fprintf chan "watch,%d,%s,%s\n" id (Utils.hexify path) (Utils.hexify token)
) (list_watches con)
let debug con =
let domid = get_domstr con in
let watches = List.map (fun (path, token) -> Printf.sprintf "watch %s: %s %s\n" domid path token) (list_watches con) in
String.concat "" watches
let domid = get_domstr con in
let watches = List.map (fun (path, token) -> Printf.sprintf "watch %s: %s %s\n" domid path token) (list_watches con) in
String.concat "" watches
let decr_conflict_credit doms con =
match con.dom with
| None -> () (* It's a socket connection. We don't know which domain we're in, so treat it as if it's free to conflict *)
| Some dom -> Domains.decr_conflict_credit doms dom
match con.dom with
| None -> () (* It's a socket connection. We don't know which domain we're in, so treat it as if it's free to conflict *)
| Some dom -> Domains.decr_conflict_credit doms dom
tools/ocaml/xenstored/connections.ml
+147 -147
View File
@@ -18,213 +18,213 @@
let debug fmt = Logging.debug "connections" fmt
type t = {
anonymous: (Unix.file_descr, Connection.t) Hashtbl.t;
domains: (int, Connection.t) Hashtbl.t;
ports: (Xeneventchn.t, Connection.t) Hashtbl.t;
mutable watches: Connection.watch list Trie.t;
mutable has_pending_watchevents: Connection.Watch.Set.t
anonymous: (Unix.file_descr, Connection.t) Hashtbl.t;
domains: (int, Connection.t) Hashtbl.t;
ports: (Xeneventchn.t, Connection.t) Hashtbl.t;
mutable watches: Connection.watch list Trie.t;
mutable has_pending_watchevents: Connection.Watch.Set.t
}
let create () = {
anonymous = Hashtbl.create 37;
domains = Hashtbl.create 37;
ports = Hashtbl.create 37;
watches = Trie.create ();
has_pending_watchevents = Connection.Watch.Set.empty;
anonymous = Hashtbl.create 37;
domains = Hashtbl.create 37;
ports = Hashtbl.create 37;
watches = Trie.create ();
has_pending_watchevents = Connection.Watch.Set.empty;
}
let get_capacity () =
(* not multiplied by maxwatch on purpose: 2nd queue in watch itself! *)
{ Xenbus.Xb.maxoutstanding = !Define.maxoutstanding; maxwatchevents = !Define.maxwatchevents }
(* not multiplied by maxwatch on purpose: 2nd queue in watch itself! *)
{ Xenbus.Xb.maxoutstanding = !Define.maxoutstanding; maxwatchevents = !Define.maxwatchevents }
let add_anonymous cons fd =
let capacity = get_capacity () in
let xbcon = Xenbus.Xb.open_fd fd ~capacity in
let con = Connection.create xbcon None in
Hashtbl.add cons.anonymous (Xenbus.Xb.get_fd xbcon) con
let capacity = get_capacity () in
let xbcon = Xenbus.Xb.open_fd fd ~capacity in
let con = Connection.create xbcon None in
Hashtbl.add cons.anonymous (Xenbus.Xb.get_fd xbcon) con
let add_domain cons dom =
let capacity = get_capacity () in
let xbcon = Xenbus.Xb.open_mmap ~capacity (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;
Hashtbl.add cons.ports (Domain.get_local_port dom) con
let capacity = get_capacity () in
let xbcon = Xenbus.Xb.open_mmap ~capacity (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;
Hashtbl.add cons.ports (Domain.get_local_port dom) con
let select ?(only_if = (fun _ -> true)) cons =
Hashtbl.fold (fun _ con (ins, outs) ->
if (only_if con) then (
let fd = Connection.get_fd con in
let in_fds = if Connection.can_input con then fd :: ins else ins in
let out_fds = if Connection.has_output con then fd :: outs else outs in
in_fds, out_fds
) else (ins, outs)
)
cons.anonymous ([], [])
Hashtbl.fold (fun _ con (ins, outs) ->
if (only_if con) then (
let fd = Connection.get_fd con in
let in_fds = if Connection.can_input con then fd :: ins else ins in
let out_fds = if Connection.has_output con then fd :: outs else outs in
in_fds, out_fds
) else (ins, outs)
)
cons.anonymous ([], [])
let find cons =
Hashtbl.find cons.anonymous
Hashtbl.find cons.anonymous
let find_domain cons =
Hashtbl.find cons.domains
Hashtbl.find cons.domains
let find_domain_by_port cons port =
Hashtbl.find cons.ports port
Hashtbl.find cons.ports port
let del_watches_of_con con watches =
match List.filter (fun w -> Connection.get_con w != con) watches with
| [] -> None
| ws -> Some ws
match List.filter (fun w -> Connection.get_con w != con) watches with
| [] -> None
| ws -> Some ws
let del_watches cons con =
Connection.del_watches con;
cons.watches <- Trie.map (del_watches_of_con con) cons.watches;
cons.has_pending_watchevents <-
cons.has_pending_watchevents |> Connection.Watch.Set.filter @@ fun w ->
Connection.get_con w != con
Connection.del_watches con;
cons.watches <- Trie.map (del_watches_of_con con) cons.watches;
cons.has_pending_watchevents <-
cons.has_pending_watchevents |> Connection.Watch.Set.filter @@ fun w ->
Connection.get_con w != con
let del_anonymous cons con =
try
Hashtbl.remove cons.anonymous (Connection.get_fd con);
del_watches cons con;
Connection.close con
with exn ->
debug "del anonymous %s" (Printexc.to_string exn)
try
Hashtbl.remove cons.anonymous (Connection.get_fd con);
del_watches cons con;
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;
(match Connection.get_domain con with
| Some d -> Hashtbl.remove cons.ports (Domain.get_local_port d)
| None -> ());
del_watches cons con;
Connection.close con
with exn ->
debug "del domain %u: %s" id (Printexc.to_string exn)
try
let con = find_domain cons id in
Hashtbl.remove cons.domains id;
(match Connection.get_domain con with
| Some d -> Hashtbl.remove cons.ports (Domain.get_local_port d)
| None -> ());
del_watches cons con;
Connection.close con
with exn ->
debug "del domain %u: %s" id (Printexc.to_string exn)
let iter_domains cons fct =
Hashtbl.iter (fun _ c -> fct c) cons.domains
Hashtbl.iter (fun _ c -> fct c) cons.domains
let iter_anonymous cons fct =
Hashtbl.iter (fun _ c -> fct c) cons.anonymous
Hashtbl.iter (fun _ c -> fct c) cons.anonymous
let iter cons fct =
iter_domains cons fct; iter_anonymous 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_work con then con :: acc else acc)
cons.domains []
Hashtbl.fold
(fun _id con acc ->
if Connection.has_more_work 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)
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
"" :: Store.Path.to_string_list path
let add_watch cons con path token =
let apath = Connection.get_watch_path con path in
(* fail on invalid paths early by calling key_of_str before adding watch *)
let key = key_of_str apath in
let watch = Connection.add_watch con (path, apath) token 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 apath = Connection.get_watch_path con path in
(* fail on invalid paths early by calling key_of_str before adding watch *)
let key = key_of_str apath in
let watch = Connection.add_watch con (path, apath) token 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
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 ?oldroot source root cons path recurse =
let key = key_of_path path in
let path = Store.Path.to_string path in
let roots = oldroot, root in
let fire_watch _ = function
| None -> ()
| Some watches -> List.iter (fun w -> Connection.fire_watch source roots w path) watches
in
let fire_rec _x = function
| None -> ()
| Some watches ->
List.iter (Connection.fire_single_watch source roots) watches
in
Trie.iter_path fire_watch cons.watches key;
if recurse then
Trie.iter fire_rec (Trie.sub cons.watches key)
let key = key_of_path path in
let path = Store.Path.to_string path in
let roots = oldroot, root in
let fire_watch _ = function
| None -> ()
| Some watches -> List.iter (fun w -> Connection.fire_watch source roots w path) watches
in
let fire_rec _x = function
| None -> ()
| Some watches ->
List.iter (Connection.fire_single_watch source roots) watches
in
Trie.iter_path fire_watch cons.watches key;
if recurse then
Trie.iter fire_rec (Trie.sub cons.watches key)
let send_watchevents cons con =
cons.has_pending_watchevents <-
cons.has_pending_watchevents |> Connection.Watch.Set.filter Connection.Watch.flush_events;
Connection.source_flush_watchevents con
cons.has_pending_watchevents <-
cons.has_pending_watchevents |> Connection.Watch.Set.filter Connection.Watch.flush_events;
Connection.source_flush_watchevents con
let fire_spec_watches root cons specpath =
let source = find_domain cons 0 in
iter cons (fun con ->
List.iter (Connection.fire_single_watch source (None, root)) (Connection.get_watches con specpath))
let source = find_domain cons 0 in
iter cons (fun con ->
List.iter (Connection.fire_single_watch source (None, root)) (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 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 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;
);
(Hashtbl.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon,
Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom)
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;
);
(Hashtbl.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon,
Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom)
let debug cons =
let anonymous = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.anonymous [] in
let domains = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.domains [] in
String.concat "" (domains @ anonymous)
let anonymous = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.anonymous [] in
let domains = Hashtbl.fold (fun _ con accu -> Connection.debug con :: accu) cons.domains [] in
String.concat "" (domains @ anonymous)
let debug_watchevents cons con =
(* == (physical equality)
has to be used here because w.con.xb.backend might contain a [unit->unit] value causing regular
comparison to fail due to having a 'functional value' which cannot be compared.
*)
let s = cons.has_pending_watchevents |> Connection.Watch.Set.filter (fun w -> w.con == con) in
let pending = s |> Connection.Watch.Set.elements
|> List.map (fun w -> Connection.Watch.pending_watchevents w) |> List.fold_left (+) 0 in
Printf.sprintf "Watches with pending events: %d, pending events total: %d" (Connection.Watch.Set.cardinal s) pending
(* == (physical equality)
has to be used here because w.con.xb.backend might contain a [unit->unit] value causing regular
comparison to fail due to having a 'functional value' which cannot be compared.
*)
let s = cons.has_pending_watchevents |> Connection.Watch.Set.filter (fun w -> w.con == con) in
let pending = s |> Connection.Watch.Set.elements
|> List.map (fun w -> Connection.Watch.pending_watchevents w) |> List.fold_left (+) 0 in
Printf.sprintf "Watches with pending events: %d, pending events total: %d" (Connection.Watch.Set.cardinal s) pending
let filter ~f cons =
let fold _ v acc = if f v then v :: acc else acc in
[]
|> Hashtbl.fold fold cons.anonymous
|> Hashtbl.fold fold cons.domains
let fold _ v acc = if f v then v :: acc else acc in
[]
|> Hashtbl.fold fold cons.anonymous
|> Hashtbl.fold fold cons.domains
let prevents_quit cons = filter ~f:Connection.prevents_live_update cons
tools/ocaml/xenstored/disk.ml
+109 -109
View File
@@ -25,133 +25,133 @@ 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")
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 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 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
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
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 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
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
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 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
(* 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
(* 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)
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)
if !enable then
try
let tfile = Printf.sprintf "%s#" xs_daemon_database in
let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ]
0o600 tfile in
Store.dump store channel;
flush channel;
close_out channel;
Unix.rename tfile xs_daemon_database
with exc ->
error "caught exn %s" (Printexc.to_string exc)
tools/ocaml/xenstored/domain.ml
+58 -58
View File
@@ -22,37 +22,37 @@ let warn fmt = Logging.warn "domain" fmt
(* A bound inter-domain event channel port pair. The remote port, and the
local port it is bound to. *)
type port_pair =
{
local: Xeneventchn.t;
remote: int;
}
{
local: Xeneventchn.t;
remote: int;
}
(* Sentinal port_pair with both set to EVTCHN_INVALID *)
let invalid_ports =
{
local = Xeneventchn.of_int 0;
remote = 0
}
{
local = Xeneventchn.of_int 0;
remote = 0
}
let string_of_port_pair p =
sprintf "(l %d, r %d)" (Xeneventchn.to_int p.local) p.remote
sprintf "(l %d, r %d)" (Xeneventchn.to_int p.local) p.remote
type t =
{
id: Xenctrl.domid;
mfn: nativeint;
interface: Xenmmap.mmap_interface;
eventchn: Event.t;
mutable ports: port_pair;
mutable bad_client: bool;
mutable io_credit: int; (* the rounds of ring process left to do, default is 0,
usually set to 1 when there is work detected, could
also set to n to give "lazy" clients extra credit *)
mutable conflict_credit: float; (* Must be positive to perform writes; a commit
that later causes conflict with another
domain's transaction costs credit. *)
mutable caused_conflicts: int64;
}
{
id: Xenctrl.domid;
mfn: nativeint;
interface: Xenmmap.mmap_interface;
eventchn: Event.t;
mutable ports: port_pair;
mutable bad_client: bool;
mutable io_credit: int; (* the rounds of ring process left to do, default is 0,
usually set to 1 when there is work detected, could
also set to n to give "lazy" clients extra credit *)
mutable conflict_credit: float; (* Must be positive to perform writes; a commit
that later causes conflict with another
domain's transaction costs credit. *)
mutable caused_conflicts: int64;
}
let is_dom0 d = d.id = 0
let get_id domain = domain.id
@@ -74,50 +74,50 @@ let is_paused_for_conflict dom = dom.conflict_credit <= 0.0
let is_free_to_conflict = is_dom0
let dump d chan =
fprintf chan "dom,%d,%nd,%d,%d\n"
d.id d.mfn d.ports.remote (Xeneventchn.to_int d.ports.local)
fprintf chan "dom,%d,%nd,%d,%d\n"
d.id d.mfn d.ports.remote (Xeneventchn.to_int d.ports.local)
let rebind_evtchn d remote_port =
Event.unbind d.eventchn d.ports.local;
let local = Event.bind_interdomain d.eventchn d.id remote_port in
let new_ports = { local; remote = remote_port } in
debug "domain %d rebind %s => %s"
d.id (string_of_port_pair d.ports) (string_of_port_pair new_ports);
d.ports <- new_ports
Event.unbind d.eventchn d.ports.local;
let local = Event.bind_interdomain d.eventchn d.id remote_port in
let new_ports = { local; remote = remote_port } in
debug "domain %d rebind %s => %s"
d.id (string_of_port_pair d.ports) (string_of_port_pair new_ports);
d.ports <- new_ports
let notify dom =
Event.notify dom.eventchn dom.ports.local
Event.notify dom.eventchn dom.ports.local
let close dom =
debug "domain %d unbind %s" dom.id (string_of_port_pair dom.ports);
Event.unbind dom.eventchn dom.ports.local;
dom.ports <- invalid_ports;
Xenmmap.unmap dom.interface
debug "domain %d unbind %s" dom.id (string_of_port_pair dom.ports);
Event.unbind dom.eventchn dom.ports.local;
dom.ports <- invalid_ports;
Xenmmap.unmap dom.interface
(* On clean start, local_port will be None, and we must bind the remote port
given. On Live Update, the event channel is already bound, and both the
local and remote port numbers come from the transfer record. *)
let make ?local_port ~remote_port id mfn interface eventchn =
let local = match local_port with
| None -> Event.bind_interdomain eventchn id remote_port
| Some p -> Xeneventchn.of_int p
in
let ports = { local; remote = remote_port } in
debug "domain %d bind %s" id (string_of_port_pair ports);
{
id = id;
mfn = mfn;
ports;
interface = interface;
eventchn = eventchn;
bad_client = false;
io_credit = 0;
conflict_credit = !Define.conflict_burst_limit;
caused_conflicts = 0L;
}
let local = match local_port with
| None -> Event.bind_interdomain eventchn id remote_port
| Some p -> Xeneventchn.of_int p
in
let ports = { local; remote = remote_port } in
debug "domain %d bind %s" id (string_of_port_pair ports);
{
id = id;
mfn = mfn;
ports;
interface = interface;
eventchn = eventchn;
bad_client = false;
io_credit = 0;
conflict_credit = !Define.conflict_burst_limit;
caused_conflicts = 0L;
}
let log_and_reset_conflict_stats logfn dom =
if dom.caused_conflicts > 0L then (
logfn dom.id dom.caused_conflicts;
dom.caused_conflicts <- 0L
)
if dom.caused_conflicts > 0L then (
logfn dom.id dom.caused_conflicts;
dom.caused_conflicts <- 0L
)
tools/ocaml/xenstored/domains.ml
+149 -149
View File
@@ -21,35 +21,35 @@ let warn fmt = Logging.warn "domains" fmt
let xc = Xenctrl.interface_open ()
type domains = {
eventchn: Event.t;
table: (Xenctrl.domid, Domain.t) Hashtbl.t;
eventchn: Event.t;
table: (Xenctrl.domid, Domain.t) Hashtbl.t;
(* N.B. the Queue module is not thread-safe but oxenstored is single-threaded. *)
(* Domains queue up to regain conflict-credit; we have a queue for
domains that are carrying some penalty and so are below the
maximum credit, and another queue for domains that have run out of
credit and so have had their access paused. *)
doms_conflict_paused: (Domain.t option ref) Queue.t;
doms_with_conflict_penalty: (Domain.t option ref) Queue.t;
(* N.B. the Queue module is not thread-safe but oxenstored is single-threaded. *)
(* Domains queue up to regain conflict-credit; we have a queue for
domains that are carrying some penalty and so are below the
maximum credit, and another queue for domains that have run out of
credit and so have had their access paused. *)
doms_conflict_paused: (Domain.t option ref) Queue.t;
doms_with_conflict_penalty: (Domain.t option ref) Queue.t;
(* A callback function to be called when we go from zero to one paused domain.
This will be to reset the countdown until the next unit of credit is issued. *)
on_first_conflict_pause: unit -> unit;
(* A callback function to be called when we go from zero to one paused domain.
This will be to reset the countdown until the next unit of credit is issued. *)
on_first_conflict_pause: unit -> unit;
(* If config is set to use individual instead of aggregate conflict-rate-limiting,
we use these counts instead of the queues. The second one includes the first. *)
mutable n_paused: int; (* Number of domains with zero or negative credit *)
mutable n_penalised: int; (* Number of domains with less than maximum credit *)
(* If config is set to use individual instead of aggregate conflict-rate-limiting,
we use these counts instead of the queues. The second one includes the first. *)
mutable n_paused: int; (* Number of domains with zero or negative credit *)
mutable n_penalised: int; (* Number of domains with less than maximum credit *)
}
let init eventchn on_first_conflict_pause = {
eventchn = eventchn;
table = Hashtbl.create 10;
doms_conflict_paused = Queue.create ();
doms_with_conflict_penalty = Queue.create ();
on_first_conflict_pause = on_first_conflict_pause;
n_paused = 0;
n_penalised = 0;
eventchn = eventchn;
table = Hashtbl.create 10;
doms_conflict_paused = Queue.create ();
doms_with_conflict_penalty = Queue.create ();
on_first_conflict_pause = on_first_conflict_pause;
n_paused = 0;
n_penalised = 0;
}
let del doms id = Hashtbl.remove doms.table id
let exist doms id = Hashtbl.mem doms.table id
@@ -59,161 +59,161 @@ let iter doms fct = Hashtbl.iter (fun _ b -> fct b) doms.table
let eventchn doms = doms.eventchn
let rec is_empty_queue q =
Queue.is_empty q ||
if !(Queue.peek q) = None
then (
ignore (Queue.pop q);
is_empty_queue q
) else false
Queue.is_empty q ||
if !(Queue.peek q) = None
then (
ignore (Queue.pop q);
is_empty_queue q
) else false
let all_at_max_credit doms =
if !Define.conflict_rate_limit_is_aggregate
then
(* Check both becuase if burst limit is 1.0 then a domain can go straight
* from max-credit to paused without getting into the penalty queue. *)
is_empty_queue doms.doms_with_conflict_penalty
&& is_empty_queue doms.doms_conflict_paused
else doms.n_penalised = 0
if !Define.conflict_rate_limit_is_aggregate
then
(* Check both becuase if burst limit is 1.0 then a domain can go straight
* from max-credit to paused without getting into the penalty queue. *)
is_empty_queue doms.doms_with_conflict_penalty
&& is_empty_queue doms.doms_conflict_paused
else doms.n_penalised = 0
(* Functions to handle queues of domains given that the domain might be deleted while in a queue. *)
let push dom queue =
Queue.push (ref (Some dom)) queue
Queue.push (ref (Some dom)) queue
let rec pop queue =
match !(Queue.pop queue) with
| None -> pop queue
| Some x -> x
match !(Queue.pop queue) with
| None -> pop queue
| Some x -> x
let remove_from_queue dom queue =
Queue.iter (fun d -> match !d with
| None -> ()
| Some x -> if x=dom then d := None) queue
Queue.iter (fun d -> match !d with
| None -> ()
| Some x -> if x=dom then d := None) queue
let cleanup doms =
let notify = ref false in
let dead_dom = ref [] in
let notify = ref false in
let dead_dom = ref [] in
Hashtbl.iter (fun id _ -> if id <> 0 then
try
let info = Xenctrl.domain_getinfo xc id in
if info.Xenctrl.shutdown || info.Xenctrl.dying then (
debug "Domain %u died (dying=%b, shutdown %b -- code %d)"
id info.Xenctrl.dying info.Xenctrl.shutdown info.Xenctrl.shutdown_code;
if info.Xenctrl.dying then
dead_dom := id :: !dead_dom
else
notify := true;
)
with Xenctrl.Error _ ->
debug "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;
if dom.Domain.conflict_credit <= !Define.conflict_burst_limit
then (
remove_from_queue dom doms.doms_with_conflict_penalty;
if (dom.Domain.conflict_credit <= 0.) then remove_from_queue dom doms.doms_conflict_paused
)
) !dead_dom;
!notify, !dead_dom
Hashtbl.iter (fun id _ -> if id <> 0 then
try
let info = Xenctrl.domain_getinfo xc id in
if info.Xenctrl.shutdown || info.Xenctrl.dying then (
debug "Domain %u died (dying=%b, shutdown %b -- code %d)"
id info.Xenctrl.dying info.Xenctrl.shutdown info.Xenctrl.shutdown_code;
if info.Xenctrl.dying then
dead_dom := id :: !dead_dom
else
notify := true;
)
with Xenctrl.Error _ ->
debug "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;
if dom.Domain.conflict_credit <= !Define.conflict_burst_limit
then (
remove_from_queue dom doms.doms_with_conflict_penalty;
if (dom.Domain.conflict_credit <= 0.) then remove_from_queue dom doms.doms_conflict_paused
)
) !dead_dom;
!notify, !dead_dom
let resume _doms _domid =
()
()
let create doms ?local_port ~remote_port domid mfn =
let interface = Xenctrl.map_foreign_range xc domid (Xenmmap.getpagesize()) mfn in
let dom = Domain.make ?local_port ~remote_port domid mfn interface doms.eventchn in
Hashtbl.add doms.table domid dom;
dom
let interface = Xenctrl.map_foreign_range xc domid (Xenmmap.getpagesize()) mfn in
let dom = Domain.make ?local_port ~remote_port domid mfn interface doms.eventchn in
Hashtbl.add doms.table domid dom;
dom
let xenstored_kva = ref ""
let xenstored_port = ref ""
let create0 ?local_port doms =
let remote_port = Utils.read_file_single_integer !xenstored_port in
let remote_port = Utils.read_file_single_integer !xenstored_port in
let interface =
let fd = Unix.openfile !xenstored_kva [ Unix.O_RDWR ] 0o600 in
let interface = Xenmmap.mmap fd Xenmmap.RDWR Xenmmap.SHARED (Xenmmap.getpagesize()) 0 in
Unix.close fd;
interface
in
let interface =
let fd = Unix.openfile !xenstored_kva [ Unix.O_RDWR ] 0o600 in
let interface = Xenmmap.mmap fd Xenmmap.RDWR Xenmmap.SHARED (Xenmmap.getpagesize()) 0 in
Unix.close fd;
interface
in
let dom = Domain.make ?local_port ~remote_port 0 Nativeint.zero interface doms.eventchn in
Hashtbl.add doms.table 0 dom;
Domain.notify dom;
dom
let dom = Domain.make ?local_port ~remote_port 0 Nativeint.zero interface doms.eventchn in
Hashtbl.add doms.table 0 dom;
Domain.notify dom;
dom
let decr_conflict_credit doms dom =
dom.Domain.caused_conflicts <- Int64.add 1L dom.Domain.caused_conflicts;
let before = dom.Domain.conflict_credit in
let after = max (-1.0) (before -. 1.0) in
debug "decr_conflict_credit dom%d %F -> %F" (Domain.get_id dom) before after;
dom.Domain.conflict_credit <- after;
let newly_penalised =
before >= !Define.conflict_burst_limit
&& after < !Define.conflict_burst_limit in
let newly_paused = before > 0.0 && after <= 0.0 in
if !Define.conflict_rate_limit_is_aggregate then (
if newly_penalised
&& after > 0.0
then (
push dom doms.doms_with_conflict_penalty
) else if newly_paused
then (
let first_pause = Queue.is_empty doms.doms_conflict_paused in
push dom doms.doms_conflict_paused;
if first_pause then doms.on_first_conflict_pause ()
) else (
(* The queues are correct already: no further action needed. *)
)
) else (
if newly_penalised then doms.n_penalised <- doms.n_penalised + 1;
if newly_paused then (
doms.n_paused <- doms.n_paused + 1;
if doms.n_paused = 1 then doms.on_first_conflict_pause ()
)
)
dom.Domain.caused_conflicts <- Int64.add 1L dom.Domain.caused_conflicts;
let before = dom.Domain.conflict_credit in
let after = max (-1.0) (before -. 1.0) in
debug "decr_conflict_credit dom%d %F -> %F" (Domain.get_id dom) before after;
dom.Domain.conflict_credit <- after;
let newly_penalised =
before >= !Define.conflict_burst_limit
&& after < !Define.conflict_burst_limit in
let newly_paused = before > 0.0 && after <= 0.0 in
if !Define.conflict_rate_limit_is_aggregate then (
if newly_penalised
&& after > 0.0
then (
push dom doms.doms_with_conflict_penalty
) else if newly_paused
then (
let first_pause = Queue.is_empty doms.doms_conflict_paused in
push dom doms.doms_conflict_paused;
if first_pause then doms.on_first_conflict_pause ()
) else (
(* The queues are correct already: no further action needed. *)
)
) else (
if newly_penalised then doms.n_penalised <- doms.n_penalised + 1;
if newly_paused then (
doms.n_paused <- doms.n_paused + 1;
if doms.n_paused = 1 then doms.on_first_conflict_pause ()
)
)
(* Give one point of credit to one domain, and update the queues appropriately. *)
let incr_conflict_credit_from_queue doms =
let process_queue q requeue_test =
let d = pop q in
let before = d.Domain.conflict_credit in (* just for debug-logging *)
d.Domain.conflict_credit <- min (d.Domain.conflict_credit +. 1.0) !Define.conflict_burst_limit;
debug "incr_conflict_credit_from_queue: dom%d: %F -> %F" (Domain.get_id d) before d.Domain.conflict_credit;
if requeue_test d.Domain.conflict_credit then (
push d q (* Make it queue up again for its next point of credit. *)
)
in
let paused_queue_test cred = cred <= 0.0 in
let penalty_queue_test cred = cred < !Define.conflict_burst_limit in
try process_queue doms.doms_conflict_paused paused_queue_test
with Queue.Empty -> (
try process_queue doms.doms_with_conflict_penalty penalty_queue_test
with Queue.Empty -> () (* Both queues are empty: nothing to do here. *)
)
let process_queue q requeue_test =
let d = pop q in
let before = d.Domain.conflict_credit in (* just for debug-logging *)
d.Domain.conflict_credit <- min (d.Domain.conflict_credit +. 1.0) !Define.conflict_burst_limit;
debug "incr_conflict_credit_from_queue: dom%d: %F -> %F" (Domain.get_id d) before d.Domain.conflict_credit;
if requeue_test d.Domain.conflict_credit then (
push d q (* Make it queue up again for its next point of credit. *)
)
in
let paused_queue_test cred = cred <= 0.0 in
let penalty_queue_test cred = cred < !Define.conflict_burst_limit in
try process_queue doms.doms_conflict_paused paused_queue_test
with Queue.Empty -> (
try process_queue doms.doms_with_conflict_penalty penalty_queue_test
with Queue.Empty -> () (* Both queues are empty: nothing to do here. *)
)
let incr_conflict_credit doms =
if !Define.conflict_rate_limit_is_aggregate
then incr_conflict_credit_from_queue doms
else (
(* Give a point of credit to every domain, subject only to the cap. *)
let inc dom =
let before = dom.Domain.conflict_credit in
let after = min (before +. 1.0) !Define.conflict_burst_limit in
dom.Domain.conflict_credit <- after;
debug "incr_conflict_credit dom%d: %F -> %F" (Domain.get_id dom) before after;
if !Define.conflict_rate_limit_is_aggregate
then incr_conflict_credit_from_queue doms
else (
(* Give a point of credit to every domain, subject only to the cap. *)
let inc dom =
let before = dom.Domain.conflict_credit in
let after = min (before +. 1.0) !Define.conflict_burst_limit in
dom.Domain.conflict_credit <- after;
debug "incr_conflict_credit dom%d: %F -> %F" (Domain.get_id dom) before after;
if before <= 0.0 && after > 0.0
then doms.n_paused <- doms.n_paused - 1;
if before <= 0.0 && after > 0.0
then doms.n_paused <- doms.n_paused - 1;
if before < !Define.conflict_burst_limit
&& after >= !Define.conflict_burst_limit
then doms.n_penalised <- doms.n_penalised - 1
in
if doms.n_penalised > 0 then iter doms inc
)
if before < !Define.conflict_burst_limit
&& after >= !Define.conflict_burst_limit
then doms.n_penalised <- doms.n_penalised - 1
in
if doms.n_penalised > 0 then iter doms inc
)
tools/ocaml/xenstored/event.ml
+14 -14
View File
@@ -16,23 +16,23 @@
(**************** high level binding ****************)
type t = {
handle: Xeneventchn.handle;
domexc: Xeneventchn.t;
handle: Xeneventchn.handle;
domexc: Xeneventchn.t;
}
(* On clean start, both parameters will be None, and we must open the evtchn
handle and bind the DOM_EXC VIRQ. On Live Update, the fd is preserved
across exec(), and the DOM_EXC VIRQ still bound. *)
let init ?fd ?domexc_port () =
let handle = match fd with
| None -> Xeneventchn.init ~cloexec:false ()
| Some fd -> fd |> Utils.FD.of_int |> Xeneventchn.fdopen
in
let domexc = match domexc_port with
| None -> Xeneventchn.bind_dom_exc_virq handle
| Some p -> Xeneventchn.of_int p
in
{ handle; domexc }
let handle = match fd with
| None -> Xeneventchn.init ~cloexec:false ()
| Some fd -> fd |> Utils.FD.of_int |> Xeneventchn.fdopen
in
let domexc = match domexc_port with
| None -> Xeneventchn.bind_dom_exc_virq handle
| Some p -> Xeneventchn.of_int p
in
{ handle; domexc }
let fd eventchn = Xeneventchn.fd eventchn.handle
let bind_interdomain eventchn domid port = Xeneventchn.bind_interdomain eventchn.handle domid port
@@ -42,6 +42,6 @@ let pending eventchn = Xeneventchn.pending eventchn.handle
let unmask eventchn port = Xeneventchn.unmask eventchn.handle port
let dump e chan =
Printf.fprintf chan "evtchn-dev,%d,%d\n"
(Utils.FD.to_int @@ Xeneventchn.fd e.handle)
(Xeneventchn.to_int e.domexc)
Printf.fprintf chan "evtchn-dev,%d,%d\n"
(Utils.FD.to_int @@ Xeneventchn.fd e.handle)
(Xeneventchn.to_int e.domexc)
tools/ocaml/xenstored/history.ml
+31 -31
View File
@@ -13,11 +13,11 @@
*)
type history_record = {
con: Connection.t; (* connection that made a change *)
tid: int; (* transaction id of the change (may be Transaction.none) *)
before: Store.t; (* the store before the change *)
after: Store.t; (* the store after the change *)
finish_count: int64; (* the commit-count at which the transaction finished *)
con: Connection.t; (* connection that made a change *)
tid: int; (* transaction id of the change (may be Transaction.none) *)
before: Store.t; (* the store before the change *)
after: Store.t; (* the store after the change *)
finish_count: int64; (* the commit-count at which the transaction finished *)
}
let history : history_record list ref = ref []
@@ -26,38 +26,38 @@ let history : history_record list ref = ref []
(* There is scope for optimisation here, replacing List.filter with something more efficient,
* probably on a different list-like structure. *)
let trim ?txn () =
Transaction.trim_short_running_transactions txn;
history := match Transaction.oldest_short_running_transaction () with
| None -> [] (* We have no open transaction, so no history is needed *)
| Some (_, txn) -> (
(* keep records with finish_count recent enough to be relevant *)
List.filter (fun r -> r.finish_count > txn.Transaction.start_count) !history
)
Transaction.trim_short_running_transactions txn;
history := match Transaction.oldest_short_running_transaction () with
| None -> [] (* We have no open transaction, so no history is needed *)
| Some (_, txn) -> (
(* keep records with finish_count recent enough to be relevant *)
List.filter (fun r -> r.finish_count > txn.Transaction.start_count) !history
)
let end_transaction txn con tid commit =
let success = Connection.end_transaction con tid commit in
trim ~txn ();
success
let success = Connection.end_transaction con tid commit in
trim ~txn ();
success
let reconnect con =
trim ();
Connection.do_reconnect con
trim ();
Connection.do_reconnect con
let push (x: history_record) =
let dom = x.con.Connection.dom in
match dom with
| None -> () (* treat socket connections as always free to conflict *)
| Some d -> if not (Domain.is_free_to_conflict d) then history := x :: !history
let dom = x.con.Connection.dom in
match dom with
| None -> () (* treat socket connections as always free to conflict *)
| Some d -> if not (Domain.is_free_to_conflict d) then history := x :: !history
(* Find the connections from records since commit-count [since] for which [f record] returns [true] *)
let filter_connections ~ignore ~since ~f =
(* The "mem" call is an optimisation, to avoid calling f if we have picked con already. *)
(* Using a hash table rather than a list is to optimise the "mem" call. *)
List.fold_left (fun acc hist_rec ->
if hist_rec.finish_count > since
&& not (hist_rec.con == ignore)
&& not (Hashtbl.mem acc hist_rec.con)
&& f hist_rec
then Hashtbl.replace acc hist_rec.con ();
acc
) (Hashtbl.create 1023) !history
(* The "mem" call is an optimisation, to avoid calling f if we have picked con already. *)
(* Using a hash table rather than a list is to optimise the "mem" call. *)
List.fold_left (fun acc hist_rec ->
if hist_rec.finish_count > since
&& not (hist_rec.con == ignore)
&& not (Hashtbl.mem acc hist_rec.con)
&& f hist_rec
then Hashtbl.replace acc hist_rec.con ();
acc
) (Hashtbl.create 1023) !history
tools/ocaml/xenstored/logging.ml
+239 -239
View File
@@ -21,138 +21,138 @@ open Printf
(* Logger common *)
type log_destination =
| File of string
| Syslog of Syslog.facility
| File of string
| Syslog of Syslog.facility
let log_destination_of_string s =
let prefix = "syslog:" in
let len_prefix = String.length prefix in
let len = String.length s in
if String.startswith prefix s
then Syslog(Syslog.facility_of_string (String.sub s len_prefix (len - len_prefix)))
else File s
let prefix = "syslog:" in
let len_prefix = String.length prefix in
let len = String.length s in
if String.startswith prefix s
then Syslog(Syslog.facility_of_string (String.sub s len_prefix (len - len_prefix)))
else File s
(* The prefix of a log line depends on the log destination *)
let prefix log_destination ?level ?key date = match log_destination with
| File _ ->
let level = match level with
| Some x -> Printf.sprintf "|%5s" x
| None -> "" in
let key = match key with
| Some x -> "|" ^ x
| None -> "" in
Printf.sprintf "[%s%s%s] " date level key
| Syslog _ ->
let key = match key with
| Some x -> "[" ^ x ^ "] "
| None -> "" in
(* Syslog handles the date and level internally *)
key
| File _ ->
let level = match level with
| Some x -> Printf.sprintf "|%5s" x
| None -> "" in
let key = match key with
| Some x -> "|" ^ x
| None -> "" in
Printf.sprintf "[%s%s%s] " date level key
| Syslog _ ->
let key = match key with
| Some x -> "[" ^ x ^ "] "
| None -> "" in
(* Syslog handles the date and level internally *)
key
type level = Debug | Info | Warn | Error | Null
type logger =
{ stop: unit -> unit;
restart: unit -> unit;
rotate: unit -> unit;
write: ?level:level -> string -> unit }
{ stop: unit -> unit;
restart: unit -> unit;
rotate: unit -> unit;
write: ?level:level -> string -> unit }
let truncate_line nb_chars line =
if String.length line > nb_chars - 1 then
let len = max (nb_chars - 1) 2 in
let dst_line = Bytes.create len in
Bytes.blit_string line 0 dst_line 0 (len - 2);
Bytes.set dst_line (len-2) '.';
Bytes.set dst_line (len-1) '.';
Bytes.unsafe_to_string dst_line
else line
if String.length line > nb_chars - 1 then
let len = max (nb_chars - 1) 2 in
let dst_line = Bytes.create len in
Bytes.blit_string line 0 dst_line 0 (len - 2);
Bytes.set dst_line (len-2) '.';
Bytes.set dst_line (len-1) '.';
Bytes.unsafe_to_string dst_line
else line
let log_rotate ref_ch log_file log_nb_files =
let file n = sprintf "%s.%i" log_file n in
let log_files =
let rec aux accu n =
if n >= log_nb_files then accu
else
if n = 1 && Sys.file_exists log_file
then aux [log_file,1] 2
else
let file = file (n-1) in
if Sys.file_exists file then
aux ((file, n) :: accu) (n+1)
else accu in
aux [] 1 in
List.iter (fun (f, n) -> Unix.rename f (file n)) log_files;
close_out !ref_ch;
ref_ch := open_out log_file
let file n = sprintf "%s.%i" log_file n in
let log_files =
let rec aux accu n =
if n >= log_nb_files then accu
else
if n = 1 && Sys.file_exists log_file
then aux [log_file,1] 2
else
let file = file (n-1) in
if Sys.file_exists file then
aux ((file, n) :: accu) (n+1)
else accu in
aux [] 1 in
List.iter (fun (f, n) -> Unix.rename f (file n)) log_files;
close_out !ref_ch;
ref_ch := open_out log_file
let make_file_logger log_file log_nb_files log_nb_lines log_nb_chars post_rotate =
let channel = ref (open_out_gen [Open_append; Open_creat] 0o644 log_file) in
let counter = ref 0 in
let stop() =
try flush !channel; close_out !channel
with _ -> () in
let restart() =
stop();
channel := open_out_gen [Open_append; Open_creat] 0o644 log_file in
let rotate() =
log_rotate channel log_file log_nb_files;
(post_rotate (): unit);
counter := 0 in
let write ?level:_ s =
let s = if log_nb_chars > 0 then truncate_line log_nb_chars s else s in
let s = s ^ "\n" in
output_string !channel s;
flush !channel;
incr counter;
if !counter > log_nb_lines then rotate() in
{ stop=stop; restart=restart; rotate=rotate; write=write }
let channel = ref (open_out_gen [Open_append; Open_creat] 0o644 log_file) in
let counter = ref 0 in
let stop() =
try flush !channel; close_out !channel
with _ -> () in
let restart() =
stop();
channel := open_out_gen [Open_append; Open_creat] 0o644 log_file in
let rotate() =
log_rotate channel log_file log_nb_files;
(post_rotate (): unit);
counter := 0 in
let write ?level:_ s =
let s = if log_nb_chars > 0 then truncate_line log_nb_chars s else s in
let s = s ^ "\n" in
output_string !channel s;
flush !channel;
incr counter;
if !counter > log_nb_lines then rotate() in
{ stop=stop; restart=restart; rotate=rotate; write=write }
exception Unknown_level of string
let int_of_level = function
| Debug -> 0 | Info -> 1 | Warn -> 2
| Error -> 3 | Null -> max_int
| Debug -> 0 | Info -> 1 | Warn -> 2
| Error -> 3 | Null -> max_int
let string_of_level = function
| Debug -> "debug" | Info -> "info" | Warn -> "warn"
| Error -> "error" | Null -> "null"
| Debug -> "debug" | Info -> "info" | Warn -> "warn"
| Error -> "error" | Null -> "null"
let level_of_string = function
| "debug" -> Debug | "info" -> Info | "warn" -> Warn
| "error" -> Error | "null" -> Null | s -> raise (Unknown_level s)
| "debug" -> Debug | "info" -> Info | "warn" -> Warn
| "error" -> Error | "null" -> Null | s -> raise (Unknown_level s)
let string_of_date () =
let time = Unix.gettimeofday () in
let tm = Unix.gmtime time in
let msec = time -. (floor time) in
sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ"
(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 time = Unix.gettimeofday () in
let tm = Unix.gmtime time in
let msec = time -. (floor time) in
sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ"
(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))
(* We can defer to syslog for log management *)
let make_syslog_logger facility =
(* When TZ is unset in the environment, each syslog call will stat the
/etc/localtime file at least three times during the process. We'd like to
avoid this cost given that we are not a mobile environment and we log
almost every xenstore entry update/watch. *)
let () =
let tz_is_set =
try String.length (Unix.getenv "TZ") > 0
with Not_found -> false in
if not tz_is_set then Unix.putenv "TZ" "/etc/localtime" in
let nothing () = () in
let write ?level s =
let level = match level with
| Some Error -> Syslog.Err
| Some Warn -> Syslog.Warning
| Some Info -> Syslog.Info
| Some Debug -> Syslog.Debug
| Some Null -> Syslog.Debug
| None -> Syslog.Debug in
(* Syslog handles the date and level internally *)
Syslog.log facility level s in
{ stop = nothing; restart = nothing; rotate = nothing; write=write }
(* When TZ is unset in the environment, each syslog call will stat the
/etc/localtime file at least three times during the process. We'd like to
avoid this cost given that we are not a mobile environment and we log
almost every xenstore entry update/watch. *)
let () =
let tz_is_set =
try String.length (Unix.getenv "TZ") > 0
with Not_found -> false in
if not tz_is_set then Unix.putenv "TZ" "/etc/localtime" in
let nothing () = () in
let write ?level s =
let level = match level with
| Some Error -> Syslog.Err
| Some Warn -> Syslog.Warning
| Some Info -> Syslog.Info
| Some Debug -> Syslog.Debug
| Some Null -> Syslog.Debug
| None -> Syslog.Debug in
(* Syslog handles the date and level internally *)
Syslog.log facility level s in
{ stop = nothing; restart = nothing; rotate = nothing; write=write }
let xenstored_log_destination = ref (File (Paths.xen_log_dir ^ "/xenstored.log"))
let xenstored_log_level = ref Warn
@@ -164,34 +164,34 @@ let xenstored_logger = ref (None: logger option)
let debug_enabled () = !xenstored_log_level = Debug
let set_xenstored_log_destination s =
xenstored_log_destination := log_destination_of_string s
xenstored_log_destination := log_destination_of_string s
let set_xenstored_logger logger =
xenstored_logger := Some logger;
logger.write ~level:Info (Printf.sprintf "Xen Storage Daemon, version %d.%d"
Define.xenstored_major Define.xenstored_minor)
xenstored_logger := Some logger;
logger.write ~level:Info (Printf.sprintf "Xen Storage Daemon, version %d.%d"
Define.xenstored_major Define.xenstored_minor)
let init_xenstored_log () = match !xenstored_log_destination with
| File file ->
if !xenstored_log_level <> Null && !xenstored_log_nb_files > 0 then
let logger =
make_file_logger
file !xenstored_log_nb_files !xenstored_log_nb_lines
!xenstored_log_nb_chars ignore in
set_xenstored_logger logger
| Syslog facility ->
set_xenstored_logger (make_syslog_logger facility)
| File file ->
if !xenstored_log_level <> Null && !xenstored_log_nb_files > 0 then
let logger =
make_file_logger
file !xenstored_log_nb_files !xenstored_log_nb_lines
!xenstored_log_nb_chars ignore in
set_xenstored_logger logger
| Syslog facility ->
set_xenstored_logger (make_syslog_logger facility)
let xenstored_logging level key (fmt: (_,_,_,_) format4) =
match !xenstored_logger with
| Some logger when int_of_level level >= int_of_level !xenstored_log_level ->
let date = string_of_date() in
let level' = string_of_level level in
let prefix = prefix !xenstored_log_destination ~level:level' ~key date in
Printf.ksprintf (fun s -> logger.write ~level (prefix ^ s)) fmt
| _ -> Printf.ksprintf ignore fmt
match !xenstored_logger with
| Some logger when int_of_level level >= int_of_level !xenstored_log_level ->
let date = string_of_date() in
let level' = string_of_level level in
let prefix = prefix !xenstored_log_destination ~level:level' ~key date in
Printf.ksprintf (fun s -> logger.write ~level (prefix ^ s)) fmt
| _ -> Printf.ksprintf ignore fmt
let debug key = xenstored_logging Debug key
let info key = xenstored_logging Info key
@@ -201,66 +201,66 @@ let error key = xenstored_logging Error key
(* Access logger *)
type access_type =
| Coalesce
| Conflict
| Commit
| Newconn
| Endconn
| Watch_not_fired
| XbOp of Xenbus.Xb.Op.operation
| Coalesce
| Conflict
| Commit
| Newconn
| Endconn
| Watch_not_fired
| XbOp of Xenbus.Xb.Op.operation
let string_of_tid ~con tid =
if tid = 0
then sprintf "%-12s" con
else sprintf "%-12s" (sprintf "%s.%i" con tid)
if tid = 0
then sprintf "%-12s" con
else sprintf "%-12s" (sprintf "%s.%i" con tid)
let string_of_access_type = function
| Coalesce -> "coalesce "
| Conflict -> "conflict "
| Commit -> "commit "
| Newconn -> "newconn "
| Endconn -> "endconn "
| Watch_not_fired -> "w notfired"
| Coalesce -> "coalesce "
| Conflict -> "conflict "
| Commit -> "commit "
| Newconn -> "newconn "
| Endconn -> "endconn "
| Watch_not_fired -> "w notfired"
| XbOp op -> match op with
| Xenbus.Xb.Op.Debug -> "debug "
| XbOp op -> match op with
| Xenbus.Xb.Op.Debug -> "debug "
| Xenbus.Xb.Op.Directory -> "directory"
| Xenbus.Xb.Op.Read -> "read "
| Xenbus.Xb.Op.Getperms -> "getperms "
| Xenbus.Xb.Op.Directory -> "directory"
| Xenbus.Xb.Op.Read -> "read "
| Xenbus.Xb.Op.Getperms -> "getperms "
| Xenbus.Xb.Op.Watch -> "watch "
| Xenbus.Xb.Op.Unwatch -> "unwatch "
| Xenbus.Xb.Op.Watch -> "watch "
| Xenbus.Xb.Op.Unwatch -> "unwatch "
| Xenbus.Xb.Op.Transaction_start -> "t start "
| Xenbus.Xb.Op.Transaction_end -> "t end "
| Xenbus.Xb.Op.Transaction_start -> "t start "
| Xenbus.Xb.Op.Transaction_end -> "t end "
| Xenbus.Xb.Op.Introduce -> "introduce"
| Xenbus.Xb.Op.Release -> "release "
| Xenbus.Xb.Op.Getdomainpath -> "getdomain"
| Xenbus.Xb.Op.Isintroduced -> "is introduced"
| Xenbus.Xb.Op.Resume -> "resume "
| Xenbus.Xb.Op.Introduce -> "introduce"
| Xenbus.Xb.Op.Release -> "release "
| Xenbus.Xb.Op.Getdomainpath -> "getdomain"
| Xenbus.Xb.Op.Isintroduced -> "is introduced"
| Xenbus.Xb.Op.Resume -> "resume "
| Xenbus.Xb.Op.Write -> "write "
| Xenbus.Xb.Op.Mkdir -> "mkdir "
| Xenbus.Xb.Op.Rm -> "rm "
| Xenbus.Xb.Op.Setperms -> "setperms "
| Xenbus.Xb.Op.Reset_watches -> "reset watches"
| Xenbus.Xb.Op.Set_target -> "settarget"
| Xenbus.Xb.Op.Write -> "write "
| Xenbus.Xb.Op.Mkdir -> "mkdir "
| Xenbus.Xb.Op.Rm -> "rm "
| Xenbus.Xb.Op.Setperms -> "setperms "
| Xenbus.Xb.Op.Reset_watches -> "reset watches"
| Xenbus.Xb.Op.Set_target -> "settarget"
| Xenbus.Xb.Op.Error -> "error "
| Xenbus.Xb.Op.Watchevent -> "w event "
| Xenbus.Xb.Op.Invalid -> "invalid "
(*
| Xenbus.Xb.Op.Error -> "error "
| Xenbus.Xb.Op.Watchevent -> "w event "
| Xenbus.Xb.Op.Invalid -> "invalid "
(*
| x -> Xenbus.Xb.Op.to_string x
*)
let sanitize_data data =
let data = String.init
(String.length data)
(fun i -> let c = data.[i] in if c = '\000' then ' ' else c)
in
String.escaped data
let data = String.init
(String.length data)
(fun i -> let c = data.[i] in if c = '\000' then ' ' else c)
in
String.escaped data
let activate_access_log = ref true
let access_log_destination = ref (File (Paths.xen_log_dir ^ "/xenstored-access.log"))
@@ -273,101 +273,101 @@ let access_log_special_ops = ref false
let access_logger = ref None
let set_access_log_destination s =
access_log_destination := log_destination_of_string s
access_log_destination := log_destination_of_string s
let init_access_log post_rotate = match !access_log_destination with
| File file ->
if !access_log_nb_files > 0 then
let logger =
make_file_logger
file !access_log_nb_files !access_log_nb_lines
!access_log_nb_chars post_rotate in
access_logger := Some logger
| Syslog facility ->
access_logger := Some (make_syslog_logger facility)
| File file ->
if !access_log_nb_files > 0 then
let logger =
make_file_logger
file !access_log_nb_files !access_log_nb_lines
!access_log_nb_chars post_rotate in
access_logger := Some logger
| Syslog facility ->
access_logger := Some (make_syslog_logger facility)
let access_logging ~con ~tid ?(data="") ~level access_type =
try
maybe
(fun logger ->
let date = string_of_date() in
let tid = string_of_tid ~con tid in
let access_type = string_of_access_type access_type in
let data = sanitize_data data in
let prefix = prefix !access_log_destination date in
let msg = Printf.sprintf "%s %s %s %s" prefix tid access_type data in
logger.write ~level msg)
!access_logger
with _ -> ()
try
maybe
(fun logger ->
let date = string_of_date() in
let tid = string_of_tid ~con tid in
let access_type = string_of_access_type access_type in
let data = sanitize_data data in
let prefix = prefix !access_log_destination date in
let msg = Printf.sprintf "%s %s %s %s" prefix tid access_type data in
logger.write ~level msg)
!access_logger
with _ -> ()
let new_connection = access_logging ~level:Debug Newconn
let end_connection = access_logging ~level:Debug Endconn
let read_coalesce ~tid ~con data =
if !access_log_read_ops
then access_logging Coalesce ~tid ~con ~data:("read "^data) ~level:Debug
if !access_log_read_ops
then access_logging Coalesce ~tid ~con ~data:("read "^data) ~level:Debug
let write_coalesce data = access_logging Coalesce ~data:("write "^data) ~level:Debug
let conflict = access_logging Conflict ~level:Debug
let commit = access_logging Commit ~level:Debug
let xb_op ~tid ~con ~ty data =
let print = match ty with
| Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !access_log_read_ops
| Xenbus.Xb.Op.Transaction_start | Xenbus.Xb.Op.Transaction_end ->
false (* transactions are managed below *)
| Xenbus.Xb.Op.Introduce | Xenbus.Xb.Op.Release | Xenbus.Xb.Op.Getdomainpath | Xenbus.Xb.Op.Isintroduced | Xenbus.Xb.Op.Resume ->
!access_log_special_ops
| _ -> true in
if print then access_logging ~tid ~con ~data (XbOp ty) ~level:Info
let print = match ty with
| Xenbus.Xb.Op.Read | Xenbus.Xb.Op.Directory | Xenbus.Xb.Op.Getperms -> !access_log_read_ops
| Xenbus.Xb.Op.Transaction_start | Xenbus.Xb.Op.Transaction_end ->
false (* transactions are managed below *)
| Xenbus.Xb.Op.Introduce | Xenbus.Xb.Op.Release | Xenbus.Xb.Op.Getdomainpath | Xenbus.Xb.Op.Isintroduced | Xenbus.Xb.Op.Resume ->
!access_log_special_ops
| _ -> true in
if print then access_logging ~tid ~con ~data (XbOp ty) ~level:Info
let start_transaction ~tid ~con =
if !access_log_transaction_ops && tid <> 0
then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start) ~level:Debug
if !access_log_transaction_ops && tid <> 0
then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_start) ~level:Debug
let end_transaction ~tid ~con =
if !access_log_transaction_ops && tid <> 0
then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end) ~level:Debug
if !access_log_transaction_ops && tid <> 0
then access_logging ~tid ~con (XbOp Xenbus.Xb.Op.Transaction_end) ~level:Debug
let live_update () =
xb_op ~tid:0 ~con:"" ~ty:Xenbus.Xb.Op.Debug "Live update begin"
xb_op ~tid:0 ~con:"" ~ty:Xenbus.Xb.Op.Debug "Live update begin"
let xb_answer ~tid ~con ~ty data =
let print, level = match ty with
| Xenbus.Xb.Op.Error when String.startswith "ENOENT" data -> !access_log_read_ops , Warn
| Xenbus.Xb.Op.Error -> true , Warn
| Xenbus.Xb.Op.Watchevent -> true , Info
| _ -> false, Debug
in
if print then access_logging ~tid ~con ~data (XbOp ty) ~level
let print, level = match ty with
| Xenbus.Xb.Op.Error when String.startswith "ENOENT" data -> !access_log_read_ops , Warn
| Xenbus.Xb.Op.Error -> true , Warn
| Xenbus.Xb.Op.Watchevent -> true , Info
| _ -> false, Debug
in
if print then access_logging ~tid ~con ~data (XbOp ty) ~level
let watch_not_fired ~con perms path =
let data = Printf.sprintf "EPERM perms=[%s] path=%s" perms path in
access_logging ~tid:0 ~con ~data Watch_not_fired ~level:Info
let data = Printf.sprintf "EPERM perms=[%s] path=%s" perms path in
access_logging ~tid:0 ~con ~data Watch_not_fired ~level:Info
let msg_of exn bt =
Printf.sprintf "Fatal exception: %s\n%s" (Printexc.to_string exn)
(Printexc.raw_backtrace_to_string bt)
Printf.sprintf "Fatal exception: %s\n%s" (Printexc.to_string exn)
(Printexc.raw_backtrace_to_string bt)
let fallback_exception_handler exn bt =
(* stderr goes to /dev/null, so use the logger where possible,
but always print to stderr too, in case everything else fails,
e.g. this can be used to debug with --no-fork
(* stderr goes to /dev/null, so use the logger where possible,
but always print to stderr too, in case everything else fails,
e.g. this can be used to debug with --no-fork
this function should try not to raise exceptions, but if it does
the ocaml runtime should still print the exception, both the original,
and the one from this function, but to stderr this time
*)
let msg = msg_of exn bt in
prerr_endline msg;
(* See Printexc.set_uncaught_exception_handler, need to flush,
so has to call stop and flush *)
match !xenstored_logger with
| Some l -> error "xenstored-fallback" "%s" msg; l.stop ()
| None ->
(* Too early, no logger set yet.
We normally try to use the configured logger so we don't flood syslog
during development for example, or if the user has a file set
*)
try Syslog.log Syslog.Daemon Syslog.Err msg
with e ->
let bt = Printexc.get_raw_backtrace () in
prerr_endline @@ msg_of e bt
this function should try not to raise exceptions, but if it does
the ocaml runtime should still print the exception, both the original,
and the one from this function, but to stderr this time
*)
let msg = msg_of exn bt in
prerr_endline msg;
(* See Printexc.set_uncaught_exception_handler, need to flush,
so has to call stop and flush *)
match !xenstored_logger with
| Some l -> error "xenstored-fallback" "%s" msg; l.stop ()
| None ->
(* Too early, no logger set yet.
We normally try to use the configured logger so we don't flood syslog
during development for example, or if the user has a file set
*)
try Syslog.log Syslog.Daemon Syslog.Err msg
with e ->
let bt = Printexc.get_raw_backtrace () in
prerr_endline @@ msg_of e bt
tools/ocaml/xenstored/packet.ml
+10 -10
View File
@@ -1,16 +1,16 @@
type request = {
tid: int;
rid: int;
ty: Xenbus.Xb.Op.operation;
data: string;
tid: int;
rid: int;
ty: Xenbus.Xb.Op.operation;
data: string;
}
type response =
| Ack of (unit -> unit) (* function is the action to execute after sending the ack *)
| Reply of string
| Error of string
| Ack of (unit -> unit) (* function is the action to execute after sending the ack *)
| Reply of string
| Error of string
let response_equal a b =
match (a, b) with
| (Ack _, Ack _) -> true (* just consider the response, not the post-response action *)
| (x, y) -> x = y
match (a, b) with
| (Ack _, Ack _) -> true (* just consider the response, not the post-response action *)
| (x, y) -> x = y
tools/ocaml/xenstored/parse_arg.ml
+53 -53
View File
@@ -15,59 +15,59 @@
*)
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;
live_reload: bool;
disable_socket: bool;
}
{
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;
live_reload: 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 live_reload = ref false
and disable_socket = ref false
in
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 live_reload = 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");
("--live", Arg.Set live_reload, "Read live dump on startup");
("--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 _ -> ()) 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;
live_reload = !live_reload;
disable_socket = !disable_socket;
}
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");
("--live", Arg.Set live_reload, "Read live dump on startup");
("--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 _ -> ()) 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;
live_reload = !live_reload;
disable_socket = !disable_socket;
}
tools/ocaml/xenstored/perms.ml
+108 -108
View File
@@ -25,72 +25,72 @@ let watch_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'
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"
match c with
| 'r' -> READ
| 'w' -> WRITE
| 'b' -> RDWR
| 'n' -> NONE
| _ -> invalid_arg "unknown permission type"
(* node permissions *)
module Node =
struct
type t =
{
owner: Xenctrl.domid;
other: permty;
acl: (Xenctrl.domid * permty) list;
}
type t =
{
owner: Xenctrl.domid;
other: permty;
acl: (Xenctrl.domid * permty) list;
}
let create owner other acl =
{ owner = owner; other = other; acl = acl }
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 get_other perms = perms.other
let get_acl perms = perms.acl
let get_owner perm = perm.owner
(** [remote_domid ~domid perm] removes all ACLs for [domid] from perm.
* If [domid] was the owner then it is changed to Dom0.
* This is used for cleaning up after dead domains.
* *)
let remove_domid ~domid perm =
let acl = List.filter (fun (acl_domid, _) -> acl_domid <> domid) perm.acl in
if perm.owner = domid then None else Some { perm with acl; owner = perm.owner }
(** [remote_domid ~domid perm] removes all ACLs for [domid] from perm.
* If [domid] was the owner then it is changed to Dom0.
* This is used for cleaning up after dead domains.
* *)
let remove_domid ~domid perm =
let acl = List.filter (fun (acl_domid, _) -> acl_domid <> domid) perm.acl in
if perm.owner = domid then None else Some { perm with acl; owner = perm.owner }
let default0 = create 0 NONE []
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 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
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
(* [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 string_of_perm perm =
Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm)
let to_string ?(sep="\000") permvec =
let l = ((permvec.owner, permvec.other) :: permvec.acl) in
String.concat sep (List.map string_of_perm l)
let to_string ?(sep="\000") permvec =
let l = ((permvec.owner, permvec.other) :: permvec.acl) in
String.concat sep (List.map string_of_perm l)
end
@@ -99,87 +99,87 @@ end
module Connection =
struct
type elt = Xenctrl.domid * (permty list)
type t =
{ main: elt;
target: elt option; }
type elt = Xenctrl.domid * (permty list)
type t =
{ main: elt;
target: elt option; }
let full_rights : t =
{ main = 0, [READ; WRITE];
target = None }
let full_rights : t =
{ main = 0, [READ; WRITE];
target = None }
let create ?(perms=[NONE]) domid : t =
{ main = (domid, perms);
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 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 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_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 is_dom0 (connection:t) =
is_owner connection 0
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 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))
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
if !activate && not (Connection.is_dom0 connection)
then Connection.is_owner connection (Node.get_owner node)
else true
(* check if the current connection lacks the requested perm on the current node *)
let lacks (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, _ ->
info "Permission denied: Domain %d has no permission" domainid;
false
| RDWR, _ -> true
| READ, READ -> true
| WRITE, WRITE -> true
| READ, _ ->
info "Permission denied: Domain %d has read only access" domainid;
false
| WRITE, _ ->
info "Permission denied: Domain %d has write only access" domainid;
false
in
!activate
&& not (Connection.is_dom0 connection)
&& not (check_owner connection node)
&& not (List.exists check_acl (Connection.get_owners connection))
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, _ ->
info "Permission denied: Domain %d has no permission" domainid;
false
| RDWR, _ -> true
| READ, READ -> true
| WRITE, WRITE -> true
| READ, _ ->
info "Permission denied: Domain %d has read only access" domainid;
false
| WRITE, _ ->
info "Permission denied: Domain %d has write only access" domainid;
false
in
!activate
&& not (Connection.is_dom0 connection)
&& not (check_owner connection node)
&& not (List.exists check_acl (Connection.get_owners connection))
(* check if the current connection has the requested perm on the current node.
* Raises an exception if it doesn't. *)
* Raises an exception if it doesn't. *)
let check connection request node =
if lacks connection request node
then raise Define.Permission_denied
if lacks connection request node
then raise Define.Permission_denied
(* check if the current connection has the requested perm on the current node *)
let has connection request node = not (lacks connection request node)
let can_fire_watch connection perms =
not !watch_activate
|| List.exists (has connection READ) perms
not !watch_activate
|| List.exists (has connection READ) perms
let equiv perm1 perm2 =
(Node.to_string perm1) = (Node.to_string perm2)
(Node.to_string perm1) = (Node.to_string perm2)
tools/ocaml/xenstored/poll.ml
+34 -34
View File
@@ -17,9 +17,9 @@
subscription flags used by poll, which have a correspondence to the
readfds, writefds, exceptfds concept as in select. *)
type event = {
mutable read: bool;
mutable write: bool;
mutable except: bool;
mutable read: bool;
mutable write: bool;
mutable except: bool;
}
external select_on_poll: (Unix.file_descr * event) array -> int -> int = "stub_select_on_poll"
@@ -28,40 +28,40 @@ external set_fd_limit: int -> unit = "stub_set_fd_limit"
(* The rlim_max given to setrlimit must not go above the system level nr_open,
which we can read from /proc/sys. *)
let get_sys_fs_nr_open () =
try
let ch = open_in "/proc/sys/fs/nr_open" in
let v = int_of_string (input_line ch) in
close_in_noerr ch; v
with _ -> 1024 * 1024
try
let ch = open_in "/proc/sys/fs/nr_open" in
let v = int_of_string (input_line ch) in
close_in_noerr ch; v
with _ -> 1024 * 1024
let init_event () = {read = false; write = false; except = false}
let poll_select in_fds out_fds exc_fds timeout =
let h = Hashtbl.create 57 in
let add_event event_set fd =
let e =
try Hashtbl.find h fd
with Not_found ->
let e = init_event () in
Hashtbl.add h fd e; e in
event_set e in
List.iter (add_event (fun x -> x.read <- true)) in_fds;
List.iter (add_event (fun x -> x.write <- true)) out_fds;
List.iter (add_event (fun x -> x.except <- true)) exc_fds;
(* Unix.stdin and init_event are dummy input as stubs, which will
always be overwritten later on. *)
let a = Array.make (Hashtbl.length h) (Unix.stdin, init_event ()) in
let i = ref (-1) in
Hashtbl.iter (fun fd event -> incr i; Array.set a !i (fd, event)) h;
let n = select_on_poll a (int_of_float (timeout *. 1000.)) in
let r = [], [], [] in
if n = 0 then r else
Array.fold_right
(fun (fd, event) (r, w, x) ->
(if event.read then fd :: r else r),
(if event.write then fd :: w else w),
(if event.except then fd :: x else x))
a r
let h = Hashtbl.create 57 in
let add_event event_set fd =
let e =
try Hashtbl.find h fd
with Not_found ->
let e = init_event () in
Hashtbl.add h fd e; e in
event_set e in
List.iter (add_event (fun x -> x.read <- true)) in_fds;
List.iter (add_event (fun x -> x.write <- true)) out_fds;
List.iter (add_event (fun x -> x.except <- true)) exc_fds;
(* Unix.stdin and init_event are dummy input as stubs, which will
always be overwritten later on. *)
let a = Array.make (Hashtbl.length h) (Unix.stdin, init_event ()) in
let i = ref (-1) in
Hashtbl.iter (fun fd event -> incr i; Array.set a !i (fd, event)) h;
let n = select_on_poll a (int_of_float (timeout *. 1000.)) in
let r = [], [], [] in
if n = 0 then r else
Array.fold_right
(fun (fd, event) (r, w, x) ->
(if event.read then fd :: r else r),
(if event.write then fd :: w else w),
(if event.except then fd :: x else x))
a r
let () =
set_fd_limit (get_sys_fs_nr_open ())
set_fd_limit (get_sys_fs_nr_open ())
tools/ocaml/xenstored/poll.mli
+2 -2
View File
@@ -15,5 +15,5 @@
(** Same interface and semantics as [Unix.select], implemented using poll(3). *)
val poll_select:
Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> float
-> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> float
-> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
tools/ocaml/xenstored/process.ml
+605 -605
View File
File diff suppressed because it is too large. Load diff
tools/ocaml/xenstored/quota.ml
+37 -37
View File
@@ -24,65 +24,65 @@ let maxent = ref (1000)
let maxsize = ref (2048)
type t = {
maxent: int; (* max entities per domU *)
maxsize: int; (* max size of data store in one node *)
cur: (Xenctrl.domid, int) Hashtbl.t; (* current domains quota *)
maxent: int; (* max entities per domU *)
maxsize: int; (* max size of data store in one node *)
cur: (Xenctrl.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
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; }
{ 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
)
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
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
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 -> ()
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 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
Hashtbl.iter (fun id nb -> set_entry quota id (get_entry quota id + nb)) diff.cur
let merge orig_quota mod_quota dest_quota =
Hashtbl.iter (fun id nb -> let diff = nb - (try get_entry orig_quota id with Not_found -> 0) in
if diff <> 0 then
set_entry dest_quota id ((try get_entry dest_quota id with Not_found -> 0) + diff)) mod_quota.cur
Hashtbl.iter (fun id nb -> let diff = nb - (try get_entry orig_quota id with Not_found -> 0) in
if diff <> 0 then
set_entry dest_quota id ((try get_entry dest_quota id with Not_found -> 0) + diff)) mod_quota.cur
tools/ocaml/xenstored/stdext.ml
+95 -95
View File
@@ -19,137 +19,137 @@ type ('a, 'b) either = Right of 'a | Left of 'b
(** apply the clean_f function after fct function has been called.
* Even if fct raises an exception, clean_f is applied
*)
*)
let exnhook = ref None
let finally fct clean_f =
let result = try
fct ();
with
exn ->
(match !exnhook with None -> () | Some f -> f exn);
clean_f (); raise exn in
clean_f ();
result
let result = try
fct ();
with
exn ->
(match !exnhook with None -> () | Some f -> f exn);
clean_f (); raise exn in
clean_f ();
result
(** if v is not none, apply f on it and return some value else return none. *)
let may f v =
match v with Some x -> Some (f x) | None -> None
match v with Some x -> Some (f x) | None -> None
(** default value to d if v is none. *)
let default d v =
match v with Some x -> x | None -> d
match v with Some x -> x | None -> d
(** apply f on v if not none *)
let maybe f v =
match v with None -> () | Some x -> f x
match v with None -> () | Some x -> f x
module Filename = struct
include Filename
let quote_command cmd args =
cmd :: args |> List.map quote |> String.concat " "
include Filename
let quote_command cmd args =
cmd :: args |> List.map quote |> String.concat " "
end
module Map = struct
module Make(Ord: Map.OrderedType) = struct
module Make(Ord: Map.OrderedType) = struct
include Map.Make(Ord)
include Map.Make(Ord)
let find_opt k t = try Some (find k t) with Not_found -> None
let find_opt k t = try Some (find k t) with Not_found -> None
let update k f t =
let r = find_opt k t in
let r' = f r in
match r, r' with
| None, None -> t
| Some _, None -> remove k t
| Some r, Some r' when r == r' -> t
| _, Some r' -> add k r' t
let update k f t =
let r = find_opt k t in
let r' = f r in
match r, r' with
| None, None -> t
| Some _, None -> remove k t
| Some r, Some r' when r == r' -> t
| _, Some r' -> add k r' t
end
end
end
module String = struct include String
let of_char c = String.make 1 c
let of_char c = String.make 1 c
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 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 fold_left f accu string =
let accu = ref accu in
for i = 0 to length string - 1 do
accu := f !accu string.[i]
done;
!accu
let fold_left f accu string =
let accu = ref accu in
for i = 0 to length string - 1 do
accu := f !accu string.[i]
done;
!accu
(** True if string 'x' starts with prefix 'prefix' *)
let startswith prefix x =
let x_l = String.length x and prefix_l = String.length prefix in
prefix_l <= x_l && String.sub x 0 prefix_l = prefix
(** True if string 'x' starts with prefix 'prefix' *)
let startswith prefix x =
let x_l = String.length x and prefix_l = String.length prefix in
prefix_l <= x_l && String.sub x 0 prefix_l = prefix
end
module Unixext = struct
(** remove a file, but doesn't raise an exception if the file is already removed *)
let unlink_safe file =
try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> ()
(** remove a file, but doesn't raise an exception if the file is already removed *)
let unlink_safe file =
try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> ()
(** create a directory but doesn't raise an exception if the directory already exist *)
let mkdir_safe dir perm =
try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
(** create a directory but doesn't raise an exception if the directory already exist *)
let mkdir_safe dir perm =
try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
(** create a directory, and create parent if doesn't exist *)
let mkdir_rec dir perm =
let rec p_mkdir dir =
let p_name = Filename.dirname dir in
if p_name <> "/" && p_name <> "."
then p_mkdir p_name;
mkdir_safe dir perm in
p_mkdir dir
(** create a directory, and create parent if doesn't exist *)
let mkdir_rec dir perm =
let rec p_mkdir dir =
let p_name = Filename.dirname dir in
if p_name <> "/" && p_name <> "."
then p_mkdir p_name;
mkdir_safe dir perm in
p_mkdir dir
(** daemonize a process *)
(* !! Must call this before spawning any threads !! *)
let daemonize () =
match Unix.fork () with
| 0 ->
if Unix.setsid () == -1 then
failwith "Unix.setsid failed";
(** daemonize a process *)
(* !! Must call this before spawning any threads !! *)
let daemonize () =
match Unix.fork () with
| 0 ->
if Unix.setsid () == -1 then
failwith "Unix.setsid failed";
begin match Unix.fork () with
| 0 ->
let nullfd = Unix.openfile "/dev/null" [ Unix.O_RDWR ] 0 in
begin try
Unix.dup2 nullfd Unix.stdin;
Unix.dup2 nullfd Unix.stdout;
Unix.dup2 nullfd Unix.stderr;
with exn -> Unix.close nullfd; raise exn
end;
Unix.close nullfd
| _ -> exit 0
end
| _ -> exit 0
begin match Unix.fork () with
| 0 ->
let nullfd = Unix.openfile "/dev/null" [ Unix.O_RDWR ] 0 in
begin try
Unix.dup2 nullfd Unix.stdin;
Unix.dup2 nullfd Unix.stdout;
Unix.dup2 nullfd Unix.stderr;
with exn -> Unix.close nullfd; raise exn
end;
Unix.close nullfd
| _ -> exit 0
end
| _ -> exit 0
(** write a pidfile file *)
let pidfile_write filename =
let fd = Unix.openfile filename
[ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ]
0o640 in
finally
(fun () ->
let pid = Unix.getpid () in
let buf = string_of_int pid ^ "\n" in
let len = String.length buf in
if Unix.write_substring fd buf 0 len <> len
then failwith "pidfile_write failed";
)
(fun () -> Unix.close fd)
(** write a pidfile file *)
let pidfile_write filename =
let fd = Unix.openfile filename
[ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ]
0o640 in
finally
(fun () ->
let pid = Unix.getpid () in
let buf = string_of_int pid ^ "\n" in
let len = String.length buf in
if Unix.write_substring fd buf 0 len <> len
then failwith "pidfile_write failed";
)
(fun () -> Unix.close fd)
end
tools/ocaml/xenstored/store.ml
+376 -376
View File
@@ -20,231 +20,231 @@ module SymbolMap = Map.Make(Symbol)
module Node = struct
type t = {
name: Symbol.t;
perms: Perms.Node.t;
value: string;
children: t SymbolMap.t;
}
type t = {
name: Symbol.t;
perms: Perms.Node.t;
value: string;
children: t SymbolMap.t;
}
let create _name _perms _value =
{ name = Symbol.of_string _name; perms = _perms; value = _value; children = SymbolMap.empty; }
let create _name _perms _value =
{ name = Symbol.of_string _name; perms = _perms; value = _value; children = SymbolMap.empty; }
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 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_value node nvalue =
if node.value = nvalue
then node
else { node with value = nvalue }
let set_perms node nperms = { node with perms = nperms }
let set_perms node nperms = { node with perms = nperms }
let add_child node child =
let children = SymbolMap.add child.name child node.children in
{ node with children }
let add_child node child =
let children = SymbolMap.add child.name child node.children in
{ node with children }
let exists node childname =
let childname = Symbol.of_string childname in
SymbolMap.mem childname node.children
let exists node childname =
let childname = Symbol.of_string childname in
SymbolMap.mem childname node.children
let find node childname =
let childname = Symbol.of_string childname in
SymbolMap.find childname node.children
let find node childname =
let childname = Symbol.of_string childname in
SymbolMap.find childname node.children
let replace_child node child nchild =
{ node with
children = SymbolMap.update child.name
(function None -> None | Some _ -> Some nchild)
node.children
}
let replace_child node child nchild =
{ node with
children = SymbolMap.update child.name
(function None -> None | Some _ -> Some nchild)
node.children
}
let del_childname node childname =
let sym = Symbol.of_string childname in
{ node with children =
SymbolMap.update sym
(function None -> raise Not_found | Some _ -> None)
node.children
}
let del_childname node childname =
let sym = Symbol.of_string childname in
{ node with children =
SymbolMap.update sym
(function None -> raise Not_found | Some _ -> None)
node.children
}
let del_all_children node =
{ node with children = SymbolMap.empty }
let del_all_children node =
{ node with children = SymbolMap.empty }
(* 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 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
Logging.info "store|node" "Permission denied: Domain %d not owner" (get_owner node);
raise Define.Permission_denied;
end
(* 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
Logging.info "store|node" "Permission denied: Domain %d not owner" (get_owner node);
raise Define.Permission_denied;
end
let rec recurse fct node = fct node; SymbolMap.iter (fun _ -> recurse fct) node.children
let rec recurse fct node = fct node; SymbolMap.iter (fun _ -> recurse fct) node.children
(** [recurse_filter_map f tree] applies [f] on each node in the tree recursively,
possibly removing some nodes.
Note that the nodes removed this way won't generate watch events.
*)
let recurse_filter_map f =
let invalid = -1 in
let is_valid _ node = node.perms.owner <> invalid in
let rec walk node =
(* Map.filter_map is Ocaml 4.11+ only *)
let node =
{ node with children =
SymbolMap.map walk node.children |> SymbolMap.filter is_valid } in
match f node with
| Some keep -> keep
| None -> { node with perms = {node.perms with owner = invalid } }
in
walk
(** [recurse_filter_map f tree] applies [f] on each node in the tree recursively,
possibly removing some nodes.
Note that the nodes removed this way won't generate watch events.
*)
let recurse_filter_map f =
let invalid = -1 in
let is_valid _ node = node.perms.owner <> invalid in
let rec walk node =
(* Map.filter_map is Ocaml 4.11+ only *)
let node =
{ node with children =
SymbolMap.map walk node.children |> SymbolMap.filter is_valid } in
match f node with
| Some keep -> keep
| None -> { node with perms = {node.perms with owner = invalid } }
in
walk
let unpack node = (Symbol.to_string node.name, node.perms, node.value)
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
(* 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 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 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 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 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 of_path_and_name path name =
match path, name with
| [], "" -> []
| _ -> path @ [name]
let of_path_and_name path name =
match path, name with
| [], "" -> []
| _ -> path @ [name]
let create path connection_path =
of_string (Utils.path_validate path connection_path)
let create path connection_path =
of_string (Utils.path_validate path connection_path)
let to_string t =
"/" ^ (String.concat "/" t)
let to_string t =
"/" ^ (String.concat "/" t)
let to_string_list x = x
let to_string_list x = x
let get_parent t =
if t = [] then [] else List.rev (List.tl (List.rev t))
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_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 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 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 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 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
)
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, return the node and a flag on the existence of the full path *)
let rec get_deepest_existing_node node = function
| [] -> node, true
| h :: t ->
try get_deepest_existing_node (Node.find node h) t
with Not_found -> node, false
(* get the deepest existing node for this path, return the node and a flag on the existence of the full path *)
let rec get_deepest_existing_node node = function
| [] -> node, true
| h :: t ->
try get_deepest_existing_node (Node.find node h) t
with Not_found -> node, false
let set_node rnode path nnode =
if path = [] then
nnode
else
let set_node node name =
try
let ent = Node.find node name in
Node.replace_child node ent nnode
with Not_found ->
Node.add_child node nnode
in
apply_modify rnode path set_node
let set_node rnode path nnode =
if path = [] then
nnode
else
let set_node node name =
try
let ent = Node.find node name in
Node.replace_child node ent nnode
with Not_found ->
Node.add_child node nnode
in
apply_modify rnode path set_node
(* 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
(* 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
let apply rnode path fct =
lookup rnode path fct
let introduce_domain = "@introduceDomain"
let release_domain = "@releaseDomain"
let specials = List.map of_string [ introduce_domain; release_domain ]
let introduce_domain = "@introduceDomain"
let release_domain = "@releaseDomain"
let specials = List.map of_string [ introduce_domain; release_domain ]
end
(* The Store.t type *)
type t =
{
mutable stat_transaction_coalesce: int;
mutable stat_transaction_abort: int;
mutable root: Node.t;
mutable quota: Quota.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
@@ -254,149 +254,149 @@ 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 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
let root = Path.apply_modify store.root path do_write in
root, !node_created
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
let root = Path.apply_modify store.root path do_write in
root, !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.check_perm store.root perm Perms.WRITE;
Node.del_all_children store.root
) else
Path.apply_modify store.root path do_rm
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.check_perm store.root perm Perms.WRITE;
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.check_perm store.root perm Perms.WRITE;
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
if path = [] then (
Node.check_perm store.root perm Perms.WRITE;
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
Path.get_node store.root path
let get_deepest_existing_node store path =
Path.get_deepest_existing_node store.root 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
if path = [] then (
let ent = store.root in
Node.check_perm ent perm Perms.READ;
ent.Node.value
) else
Path.apply store.root path do_read
let do_read node name =
let ent = Node.find node name in
Node.check_perm ent perm Perms.READ;
ent.Node.value
in
if path = [] then (
let ent = store.root in
Node.check_perm ent perm Perms.READ;
ent.Node.value
) else
Path.apply store.root path do_read
let ls store perm path =
let children =
if path = [] then (
Node.check_perm store.root perm Perms.READ;
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
SymbolMap.fold (fun k _ accu -> Symbol.to_string k :: accu) children []
let children =
if path = [] then (
Node.check_perm store.root perm Perms.READ;
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
SymbolMap.fold (fun k _ accu -> Symbol.to_string k :: accu) children []
let getperms store perm path =
if path = [] then (
Node.check_perm store.root perm Perms.READ;
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
if path = [] then (
Node.check_perm store.root perm Perms.READ;
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
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;
let node_path = Path.of_path_and_name path (Symbol.to_string node.Node.name) in
SymbolMap.iter (fun _ -> _traversal node_path) node.Node.children
in
_traversal [] root_node
let rec _traversal path node =
f path node;
let node_path = Path.of_path_and_name path (Symbol.to_string node.Node.name) in
SymbolMap.iter (fun _ -> _traversal node_path) 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 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 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
@@ -406,109 +406,109 @@ let dump_buffer store = dump_store_buf store.root
(* modifying functions with quota udpate *)
let set_node store path node orig_quota mod_quota =
let root = Path.set_node store.root path node in
store.root <- root;
Quota.merge orig_quota mod_quota store.quota
let root = Path.set_node store.root path node in
store.root <- root;
Quota.merge orig_quota mod_quota store.quota
let write store perm path value =
let node, existing = get_deepest_existing_node store path in
let owner = Node.get_owner node in
if existing || (Perms.Connection.is_dom0 perm) then
(* Only check the string length limit *)
Quota.check store.quota (-1) (String.length value)
else
(* Check the domain entries limit too *)
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 node, existing = get_deepest_existing_node store path in
let owner = Node.get_owner node in
if existing || (Perms.Connection.is_dom0 perm) then
(* Only check the string length limit *)
Quota.check store.quota (-1) (String.length value)
else
(* Check the domain entries limit too *)
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 node, existing = get_deepest_existing_node store path in
let owner = Node.get_owner node in
(* It's upt to the mkdir logic to decide what to do with existing path *)
if not (existing || (Perms.Connection.is_dom0 perm)) then Quota.check store.quota owner 0;
store.root <- path_mkdir store perm path;
if not existing then
Quota.add_entry store.quota owner
let node, existing = get_deepest_existing_node store path in
let owner = Node.get_owner node in
(* It's upt to the mkdir logic to decide what to do with existing path *)
if not (existing || (Perms.Connection.is_dom0 perm)) then Quota.check store.quota owner 0;
store.root <- path_mkdir store perm path;
if not existing then
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 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
if not ((old_owner = new_owner) || (Perms.Connection.is_dom0 perm)) then
raise Define.Permission_denied;
store.root <- path_setperms store perm path nperms;
Quota.del_entry store.quota old_owner;
Quota.add_entry store.quota new_owner
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
if not ((old_owner = new_owner) || (Perms.Connection.is_dom0 perm)) then
raise Define.Permission_denied;
store.root <- path_setperms store perm path nperms;
Quota.del_entry store.quota old_owner;
Quota.add_entry store.quota new_owner
let reset_permissions store domid =
Logging.info "store|node" "Cleaning up xenstore ACLs for domid %d" domid;
store.root <- Node.recurse_filter_map (fun node ->
match Perms.Node.remove_domid ~domid node.perms with
| None -> None
| Some perms ->
if perms <> node.perms then
Logging.debug "store|node" "Changed permissions for node %s" (Node.get_name node);
Some { node with Node.perms }
) store.root
Logging.info "store|node" "Cleaning up xenstore ACLs for domid %d" domid;
store.root <- Node.recurse_filter_map (fun node ->
match Perms.Node.remove_domid ~domid node.perms with
| None -> None
| Some perms ->
if perms <> node.perms then
Logging.debug "store|node" "Changed permissions for node %s" (Node.get_name node);
Some { node with Node.perms }
) store.root
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;
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;
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 ();
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;
stat_transaction_coalesce = store.stat_transaction_coalesce;
stat_transaction_abort = store.stat_transaction_abort;
root = store.root;
quota = Quota.copy store.quota;
}
let incr_transaction_coalesce store =
store.stat_transaction_coalesce <- store.stat_transaction_coalesce + 1
store.stat_transaction_coalesce <- store.stat_transaction_coalesce + 1
let incr_transaction_abort store =
store.stat_transaction_abort <- store.stat_transaction_abort + 1
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
let nb_nodes = ref 0 in
traversal store.root (fun _path _node ->
incr nb_nodes
);
!nb_nodes, store.stat_transaction_abort, store.stat_transaction_coalesce
tools/ocaml/xenstored/symbol.ml
+1 -1
View File
@@ -18,7 +18,7 @@ module WeakTable = Weak.Make(struct
type t = string
let equal (x:string) (y:string) = (x = y)
let hash = Hashtbl.hash
end)
end)
type t = string
tools/ocaml/xenstored/syslog.ml
+24 -24
View File
@@ -15,32 +15,32 @@
type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern
| Local0 | Local1 | Local2 | Local3
| Local4 | Local5 | Local6 | Local7
| Lpr | Mail | News | Syslog | User | Uucp
| Local4 | Local5 | Local6 | Local7
| Lpr | Mail | News | Syslog | User | Uucp
external log : facility -> level -> string -> unit = "stub_syslog"
exception Unknown_facility of string
let facility_of_string s =
match s with
|"auth"->Auth
|"authpriv"->Authpriv
|"cron"->Cron
|"daemon"->Daemon
|"ftp"->Ftp
|"kern"->Kern
|"local0"->Local0
|"local1"->Local1
|"local2"->Local2
|"local3"->Local3
|"local4"->Local4
|"local5"->Local5
|"local6"->Local6
|"local7"->Local7
|"lpr"->Lpr
|"mail"->Mail
|"news"->News
|"syslog"->Syslog
|"user"->User
|"uucp"->Uucp
|_-> raise (Unknown_facility s)
match s with
|"auth"->Auth
|"authpriv"->Authpriv
|"cron"->Cron
|"daemon"->Daemon
|"ftp"->Ftp
|"kern"->Kern
|"local0"->Local0
|"local1"->Local1
|"local2"->Local2
|"local3"->Local3
|"local4"->Local4
|"local5"->Local5
|"local6"->Local6
|"local7"->Local7
|"lpr"->Lpr
|"mail"->Mail
|"news"->News
|"syslog"->Syslog
|"user"->User
|"uucp"->Uucp
|_-> raise (Unknown_facility s)
tools/ocaml/xenstored/transaction.ml
+176 -176
View File
@@ -23,71 +23,71 @@ 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 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)
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 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 _ -> true
)
| _ ->
false
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 _ -> true
)
| _ ->
false
let can_coalesce oldroot currentroot path =
if !do_coalesce then
try test_coalesce oldroot currentroot path with _ -> false
else
false
if !do_coalesce then
try test_coalesce oldroot currentroot path with _ -> false
else
false
type ty = No | Full of (
int * (* Transaction id *)
Store.t * (* Original store *)
Store.t (* A pointer to the canonical store: its root changes on each transaction-commit *)
)
int * (* Transaction id *)
Store.t * (* Original store *)
Store.t (* A pointer to the canonical store: its root changes on each transaction-commit *)
)
type t = {
ty: ty;
start_count: int64;
store: Store.t; (* This is the store that we change in write operations. *)
quota: Quota.t;
oldroot: Store.Node.t;
mutable paths: (Xenbus.Xb.Op.operation * Store.Path.t) list;
mutable operations: (Packet.request * Packet.response) list;
mutable quota_reached: bool;
mutable read_lowpath: Store.Path.t option;
mutable write_lowpath: Store.Path.t option;
ty: ty;
start_count: int64;
store: Store.t; (* This is the store that we change in write operations. *)
quota: Quota.t;
oldroot: Store.Node.t;
mutable paths: (Xenbus.Xb.Op.operation * Store.Path.t) list;
mutable operations: (Packet.request * Packet.response) list;
mutable quota_reached: bool;
mutable read_lowpath: Store.Path.t option;
mutable write_lowpath: Store.Path.t option;
}
let get_id t = match t.ty with No -> none | Full (id, _, _) -> id
@@ -95,48 +95,48 @@ let counter = ref 0L
let failed_commits = ref 0L
let failed_commits_no_culprit = ref 0L
let reset_conflict_stats () =
failed_commits := 0L;
failed_commits_no_culprit := 0L
failed_commits := 0L;
failed_commits_no_culprit := 0L
(* Scope for optimisation: different data-structure and functions to search/filter it *)
let short_running_txns = ref []
let oldest_short_running_transaction () =
let rec last = function
| [] -> None
| [x] -> Some x
| _ :: xs -> last xs
in last !short_running_txns
let rec last = function
| [] -> None
| [x] -> Some x
| _ :: xs -> last xs
in last !short_running_txns
let trim_short_running_transactions txn =
let cutoff = Unix.gettimeofday () -. !Define.conflict_max_history_seconds in
let keep = match txn with
| None -> (function (start_time, _) -> start_time >= cutoff)
| Some t -> (function (start_time, tx) -> start_time >= cutoff && tx != t)
in
short_running_txns := List.filter
keep
!short_running_txns
let cutoff = Unix.gettimeofday () -. !Define.conflict_max_history_seconds in
let keep = match txn with
| None -> (function (start_time, _) -> start_time >= cutoff)
| Some t -> (function (start_time, tx) -> start_time >= cutoff && tx != t)
in
short_running_txns := List.filter
keep
!short_running_txns
let make ?(internal=false) id store =
let ty = if id = none then No else Full(id, Store.copy store, store) in
let txn = {
ty = ty;
start_count = !counter;
store = if id = none then store else Store.copy store;
quota = Quota.copy store.Store.quota;
oldroot = Store.get_root store;
paths = [];
operations = [];
quota_reached = false;
read_lowpath = None;
write_lowpath = None;
} in
if id <> none && not internal then (
let now = Unix.gettimeofday () in
short_running_txns := (now, txn) :: !short_running_txns
);
txn
let ty = if id = none then No else Full(id, Store.copy store, store) in
let txn = {
ty = ty;
start_count = !counter;
store = if id = none then store else Store.copy store;
quota = Quota.copy store.Store.quota;
oldroot = Store.get_root store;
paths = [];
operations = [];
quota_reached = false;
read_lowpath = None;
write_lowpath = None;
} in
if id <> none && not internal then (
let now = Unix.gettimeofday () in
short_running_txns := (now, txn) :: !short_running_txns
);
txn
let get_store t = t.store
let get_paths t = t.paths
@@ -148,115 +148,115 @@ let add_wop t ty path = t.paths <- (ty, path) :: t.paths
let get_operations t = List.rev t.operations
let check_quota_exn ~perm t =
if !Define.maxrequests >= 0
&& not (Perms.Connection.is_dom0 perm)
&& (t.quota_reached || List.length t.operations >= !Define.maxrequests)
then begin
t.quota_reached <- true;
raise Quota.Limit_reached;
end
if !Define.maxrequests >= 0
&& not (Perms.Connection.is_dom0 perm)
&& (t.quota_reached || List.length t.operations >= !Define.maxrequests)
then begin
t.quota_reached <- true;
raise Quota.Limit_reached;
end
let add_operation t request response =
t.operations <- (request, response) :: t.operations
t.operations <- (request, response) :: t.operations
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 Xenbus.Xb.Op.Write path
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 Xenbus.Xb.Op.Write path
let mkdir ?(with_watch=true) t perm path =
Store.mkdir t.store perm path;
set_write_lowpath t (Store.Path.get_parent path);
if with_watch then
add_wop t Xenbus.Xb.Op.Mkdir path
Store.mkdir t.store perm path;
set_write_lowpath t (Store.Path.get_parent path);
if with_watch then
add_wop t Xenbus.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 Xenbus.Xb.Op.Setperms path
Store.setperms t.store perm path perms;
set_write_lowpath t path;
add_wop t Xenbus.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 Xenbus.Xb.Op.Rm path
Store.rm t.store perm path;
set_write_lowpath t (Store.Path.get_parent path);
add_wop t Xenbus.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 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 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 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.paths > 0 in
let has_coalesced = ref false in
let has_commited =
match t.ty with
| No -> true
| Full (_id, oldstore, cstore) -> (* "cstore" meaning current canonical store *)
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
let has_write_ops = List.length t.paths > 0 in
let has_coalesced = ref false in
let has_commited =
match t.ty with
| No -> true
| Full (_id, oldstore, cstore) -> (* "cstore" meaning current canonical store *)
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 t.quota store.Store.quota) 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 (Store.get_root oldstore) 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
(* 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 t.quota store.Store.quota) 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 (Store.get_root oldstore) cstore t.store
in
if has_commited && has_write_ops then
Disk.write t.store;
if not has_commited
then Logging.conflict ~tid:(get_id t) ~con
else if not !has_coalesced
then Logging.commit ~tid:(get_id t) ~con;
has_commited
tools/ocaml/xenstored/trie.ml
+111 -111
View File
@@ -19,159 +19,159 @@ module StringMap = Map.Make(String)
module Node =
struct
type 'a t = {
key: string;
value: 'a option;
children: 'a t StringMap.t;
}
type 'a t = {
key: string;
value: 'a option;
children: 'a t StringMap.t;
}
let _create key value = {
key = key;
value = Some value;
children = StringMap.empty;
}
let _create key value = {
key = key;
value = Some value;
children = StringMap.empty;
}
let empty key = {
key = key;
value = None;
children = StringMap.empty;
}
let empty key = {
key = key;
value = None;
children = StringMap.empty;
}
let _get_key node = node.key
let get_value node =
match node.value with
| None -> raise Not_found
| Some value -> value
let _get_key node = node.key
let get_value node =
match node.value with
| None -> raise Not_found
| Some value -> value
let _get_children node = node.children
let _get_children node = node.children
let set_value node value =
{ node with value = Some value }
let set_children node children =
{ node with children = children }
let set_value node value =
{ node with value = Some value }
let set_children node children =
{ node with children = children }
let _add_child node child =
{ node with children = StringMap.add child.key child node.children }
let _add_child node child =
{ node with children = StringMap.add child.key child node.children }
end
type 'a t = 'a Node.t StringMap.t
let mem_node nodes key =
StringMap.mem key nodes
StringMap.mem key nodes
let find_node nodes key =
StringMap.find key nodes
StringMap.find key nodes
let replace_node nodes key node =
StringMap.update key (function None -> None | Some _ -> Some node) nodes
StringMap.update key (function None -> None | Some _ -> Some node) nodes
let remove_node nodes key =
StringMap.update key (function None -> raise Not_found | Some _ -> None) nodes
StringMap.update key (function None -> raise Not_found | Some _ -> None) nodes
let create () = StringMap.empty
let rec iter f tree =
let aux key node =
f key node.Node.value;
iter f node.Node.children
in
StringMap.iter aux tree
let aux key node =
f key node.Node.value;
iter f node.Node.children
in
StringMap.iter aux tree
let rec map f tree =
let aux node =
let value =
match node.Node.value with
| None -> None
| Some value -> f value
in
{ node with Node.value = value; Node.children = map f node.Node.children }
in
tree |> StringMap.map aux
|> StringMap.filter (fun _ n -> n.Node.value <> None || not (StringMap.is_empty n.Node.children))
let aux node =
let value =
match node.Node.value with
| None -> None
| Some value -> f value
in
{ node with Node.value = value; Node.children = map f node.Node.children }
in
tree |> StringMap.map aux
|> StringMap.filter (fun _ n -> n.Node.value <> None || not (StringMap.is_empty n.Node.children))
let rec fold f tree acc =
let aux key node accu =
fold f node.Node.children (f key node.Node.value accu)
in
StringMap.fold aux tree acc
let aux key node accu =
fold f node.Node.children (f key node.Node.value accu)
in
StringMap.fold aux tree acc
(* return a sub-trie *)
let rec sub_node tree = function
| [] -> raise Not_found
| h::t ->
if mem_node tree h
then begin
let node = find_node tree h in
if t = []
then node
else sub_node node.Node.children t
end else
raise Not_found
| [] -> raise Not_found
| h::t ->
if mem_node tree h
then begin
let node = find_node tree h in
if t = []
then node
else sub_node node.Node.children t
end else
raise Not_found
let sub tree path =
try (sub_node tree path).Node.children
with Not_found -> StringMap.empty
try (sub_node tree path).Node.children
with Not_found -> StringMap.empty
let find tree path =
Node.get_value (sub_node tree path)
Node.get_value (sub_node tree path)
(* return false if the node doesn't exists or if it is not associated to any value *)
let rec mem tree = function
| [] -> false
| h::t ->
mem_node tree h
&& (let node = find_node tree h in
if t = []
then node.Node.value <> None
else mem node.Node.children t)
| [] -> false
| h::t ->
mem_node tree h
&& (let node = find_node tree h in
if t = []
then node.Node.value <> None
else mem node.Node.children t)
(* Iterate over the longest valid prefix *)
let rec iter_path f tree = function
| [] -> ()
| h::l ->
if mem_node tree h
then begin
let node = find_node tree h in
f node.Node.key node.Node.value;
iter_path f node.Node.children l
end
| [] -> ()
| h::l ->
if mem_node tree h
then begin
let node = find_node tree h in
f node.Node.key node.Node.value;
iter_path f node.Node.children l
end
let rec set_node node path value =
if path = []
then Node.set_value node value
else begin
let children = set node.Node.children path value in
Node.set_children node children
end
if path = []
then Node.set_value node value
else begin
let children = set node.Node.children path value in
Node.set_children node children
end
and set tree path value =
match path with
| [] -> raise Not_found
| h::t ->
if mem_node tree h
then begin
let node = find_node tree h in
replace_node tree h (set_node node t value)
end else begin
let node = Node.empty h in
StringMap.add node.Node.key (set_node node t value) tree
end
match path with
| [] -> raise Not_found
| h::t ->
if mem_node tree h
then begin
let node = find_node tree h in
replace_node tree h (set_node node t value)
end else begin
let node = Node.empty h in
StringMap.add node.Node.key (set_node node t value) tree
end
let rec unset tree = function
| [] -> tree
| h::t ->
if mem_node tree h
then begin
let node = find_node tree h in
let children = unset node.Node.children t in
let new_node =
if t = []
then Node.set_children (Node.empty h) children
else Node.set_children node children
in
if StringMap.is_empty children && new_node.Node.value = None
then remove_node tree h
else replace_node tree h new_node
end else
raise Not_found
| [] -> tree
| h::t ->
if mem_node tree h
then begin
let node = find_node tree h in
let children = unset node.Node.children t in
let new_node =
if t = []
then Node.set_children (Node.empty h) children
else Node.set_children node children
in
if StringMap.is_empty children && new_node.Node.value = None
then remove_node tree h
else replace_node tree h new_node
end else
raise Not_found
tools/ocaml/xenstored/trie.mli
+11 -11
View File
@@ -17,44 +17,44 @@
type 'a t
(** The type of tries. ['a] the type of values.
Internally, a trie is represented as a labeled tree, where node contains values
of type [string * 'a option]. *)
Internally, a trie is represented as a labeled tree, where node contains values
of type [string * 'a option]. *)
val create : unit -> 'a t
(** Creates an empty trie. *)
val mem : 'a t -> string list -> bool
(** [mem t k] returns true if a value is associated with the key [k] in the trie [t].
Otherwise, it returns false. *)
Otherwise, it returns false. *)
val find : 'a t -> string list -> 'a
(** [find t k] returns the value associated with the key [k] in the trie [t].
Returns [Not_found] if no values are associated with [k] in [t]. *)
Returns [Not_found] if no values are associated with [k] in [t]. *)
val set : 'a t -> string list -> 'a -> 'a t
(** [set t k v] associates the value [v] with the key [k] in the trie [t]. *)
val unset : 'a t -> string list -> 'a t
(** [unset k v] removes the association of value [v] with the key [k] in the trie [t].
Moreover, it automatically clean the trie, ie. it removes recursively
every nodes of [t] containing no values and having no chil. *)
Moreover, it automatically clean the trie, ie. it removes recursively
every nodes of [t] containing no values and having no chil. *)
val iter : (string -> 'a option -> unit) -> 'a t -> unit
(** [iter f t] applies the function [f] to every node of the trie [t].
As nodes of the trie [t] do not necessary contains a value, the second argument of
[f] is an option type. *)
As nodes of the trie [t] do not necessary contains a value, the second argument of
[f] is an option type. *)
val iter_path : (string -> 'a option -> unit) -> 'a t -> string list -> unit
(** [iter_path f t p] iterates [f] over nodes associated with the path [p] in the trie [t].
If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *)
If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *)
val fold : (string -> 'a option -> 'c -> 'c) -> 'a t -> 'c -> 'c
(** [fold f t x] fold [f] over every nodes of [t], with [x] as initial value. *)
val map : ('a -> 'b option) -> 'a t -> 'b t
(** [map f t] maps [f] over every values stored in [t]. The return value of [f] is of type 'c option
as one may wants to remove value associated to a key. This function is not tail-recursive. *)
as one may wants to remove value associated to a key. This function is not tail-recursive. *)
val sub : 'a t -> string list -> 'a t
(** [sub t p] returns the sub-trie associated with the path [p] in the trie [t].
If [p] is not a valid path of [t], it returns an empty trie. *)
If [p] is not a valid path of [t], it returns an empty trie. *)
tools/ocaml/xenstored/utils.ml
+73 -73
View File
@@ -19,111 +19,111 @@ open Stdext
(* lists utils *)
let filter_out filter l =
List.filter (fun x -> not (List.mem x 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
List.filter (fun x -> List.mem x filter) l
let list_remove element l =
List.filter (fun e -> e != 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
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 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 = Bytes.create (String.length s * 2) in
String.iteri (fun i c ->
let seq = hexseq_of_char c in
Bytes.set hs (i * 2) seq.[0];
Bytes.set hs (i * 2 + 1) seq.[1];
) s;
Bytes.unsafe_to_string hs
let hexseq_of_char c = sprintf "%02x" (Char.code c) in
let hs = Bytes.create (String.length s * 2) in
String.iteri (fun i c ->
let seq = hexseq_of_char c in
Bytes.set hs (i * 2) seq.[0];
Bytes.set hs (i * 2 + 1) seq.[1];
) s;
Bytes.unsafe_to_string hs
let unhexify hs =
let char_of_hexseq seq0 seq1 = Char.chr (int_of_string (sprintf "0x%c%c" seq0 seq1)) in
let b = Bytes.create (String.length hs / 2) in
for i = 0 to Bytes.length b - 1
do
Bytes.set b i (char_of_hexseq hs.[i * 2] hs.[i * 2 + 1])
done;
Bytes.unsafe_to_string b
let char_of_hexseq seq0 seq1 = Char.chr (int_of_string (sprintf "0x%c%c" seq0 seq1)) in
let b = Bytes.create (String.length hs / 2) in
for i = 0 to Bytes.length b - 1
do
Bytes.set b i (char_of_hexseq hs.[i * 2] hs.[i * 2 + 1])
done;
Bytes.unsafe_to_string b
let trim_path path =
try
let rindex = String.rindex path '/' in
String.sub path 0 rindex
with
Not_found -> ""
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
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 = Bytes.make 20 '\000' in
let sz = Unix.read fd buf 0 20 in
Unix.close fd;
int_of_string (Bytes.sub_string buf 0 sz)
let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in
let buf = Bytes.make 20 '\000' in
let sz = Unix.read fd buf 0 20 in
Unix.close fd;
int_of_string (Bytes.sub_string buf 0 sz)
(* @path may be guest data and needs its length validating. @connection_path
* is generated locally in xenstored and always of the form "/local/domain/$N/" *)
let path_validate path connection_path =
let len = String.length path in
let len = String.length path in
if len = 0 then raise Define.Invalid_path;
if len = 0 then raise Define.Invalid_path;
let abs_path =
match String.get path 0 with
| '/' | '@' -> path
| _ -> connection_path ^ path
in
let abs_path =
match String.get path 0 with
| '/' | '@' -> path
| _ -> connection_path ^ path
in
(* Regardless whether client specified absolute or relative path,
canonicalize it (above) and, for domain-relative paths, check the
length of the relative part.
(* Regardless whether client specified absolute or relative path,
canonicalize it (above) and, for domain-relative paths, check the
length of the relative part.
This prevents paths becoming invalid across migrate when the length
of the domid changes in @param connection_path.
*)
let len = String.length abs_path in
let on_absolute _ _ = len in
let on_relative _ offset = len - offset in
let len = Scanf.ksscanf abs_path on_absolute "/local/domain/%d/%n" on_relative in
if len > !Define.path_max then raise Define.Invalid_path;
This prevents paths becoming invalid across migrate when the length
of the domid changes in @param connection_path.
*)
let len = String.length abs_path in
let on_absolute _ _ = len in
let on_relative _ offset = len - offset in
let len = Scanf.ksscanf abs_path on_absolute "/local/domain/%d/%n" on_relative in
if len > !Define.path_max then raise Define.Invalid_path;
abs_path
abs_path
module FD : sig
type t = Unix.file_descr
val of_int: int -> t
val to_int : t -> int
type t = Unix.file_descr
val of_int: int -> t
val to_int : t -> int
end = struct
type t = Unix.file_descr
(* This is like Obj.magic but just for these types,
and relies on Unix.file_descr = int *)
external to_int : t -> int = "%identity"
external of_int : int -> t = "%identity"
type t = Unix.file_descr
(* This is like Obj.magic but just for these types,
and relies on Unix.file_descr = int *)
external to_int : t -> int = "%identity"
external of_int : int -> t = "%identity"
end
tools/ocaml/xenstored/xenstored.ml
+489 -489
View File
File diff suppressed because it is too large. Load diff
Reference in new issue
xen-project/xen
Block a user
Blocking a user prevents them from interacting with repositories, such as opening or commenting on pull requests or issues. Learn more about blocking a user.

The note is not visible to the blocked user.