diff --git a/tools/ocaml/libs/eventchn/META.in b/tools/ocaml/libs/eventchn/META.in new file mode 100644 index 0000000..f3e01aa --- /dev/null +++ b/tools/ocaml/libs/eventchn/META.in @@ -0,0 +1,4 @@ +version = "@VERSION@" +description = "Eventchn interface extension" +archive(byte) = "eventchn.cma" +archive(native) = "eventchn.cmxa" diff --git a/tools/ocaml/libs/eventchn/Makefile b/tools/ocaml/libs/eventchn/Makefile new file mode 100644 index 0000000..9d6ef31 --- /dev/null +++ b/tools/ocaml/libs/eventchn/Makefile @@ -0,0 +1,28 @@ +TOPLEVEL=../.. +include $(TOPLEVEL)/common.make + +OBJS = eventchn +INTF = $(foreach obj, $(OBJS),$(obj).cmi) +LIBS = eventchn.cma eventchn.cmxa + +all: $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +eventchn_OBJS = $(OBJS) +eventchn_C_OBJS = eventchn_stubs + +OCAML_LIBRARY = eventchn + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore eventchn META $(INTF) $(LIBS) *.a *.so *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove eventchn + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/eventchn/eventchn.ml b/tools/ocaml/libs/eventchn/eventchn.ml new file mode 100644 index 0000000..c4a7fa3 --- /dev/null +++ b/tools/ocaml/libs/eventchn/eventchn.ml @@ -0,0 +1,27 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +exception Error of string + +external init: unit -> Unix.file_descr = "stub_eventchn_init" +external notify: Unix.file_descr -> int -> unit = "stub_eventchn_notify" +external bind_interdomain: Unix.file_descr -> int -> int -> int = "stub_eventchn_bind_interdomain" +external bind_virq: Unix.file_descr -> int = "stub_eventchn_bind_virq" +external unbind: Unix.file_descr -> int -> unit = "stub_eventchn_unbind" +external read_port: Unix.file_descr -> int = "stub_eventchn_read_port" +external write_port: Unix.file_descr -> int -> unit = "stub_eventchn_write_port" + +let _ = Callback.register_exception "eventchn.error" (Error "register_callback") diff --git a/tools/ocaml/libs/eventchn/eventchn.mli b/tools/ocaml/libs/eventchn/eventchn.mli new file mode 100644 index 0000000..7088700 --- /dev/null +++ b/tools/ocaml/libs/eventchn/eventchn.mli @@ -0,0 +1,26 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +exception Error of string +external init : unit -> Unix.file_descr = "stub_eventchn_init" +external notify : Unix.file_descr -> int -> unit = "stub_eventchn_notify" +external bind_interdomain : Unix.file_descr -> int -> int -> int + = "stub_eventchn_bind_interdomain" +external bind_virq : Unix.file_descr -> int = "stub_eventchn_bind_virq" +external unbind : Unix.file_descr -> int -> unit = "stub_eventchn_unbind" +external read_port : Unix.file_descr -> int = "stub_eventchn_read_port" +external write_port : Unix.file_descr -> int -> unit + = "stub_eventchn_write_port" diff --git a/tools/ocaml/libs/eventchn/eventchn_stubs.c b/tools/ocaml/libs/eventchn/eventchn_stubs.c new file mode 100644 index 0000000..ab61b0a --- /dev/null +++ b/tools/ocaml/libs/eventchn/eventchn_stubs.c @@ -0,0 +1,173 @@ +/* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + */ + +#include +#include +#include +#include +#include +#include + +#include + +#define __XEN_TOOLS__ + +#include + +#if XEN_SYSCTL_INTERFACE_VERSION < 4 +#include +#else +#include +#include +#endif + +#include + +#define CAML_NAME_SPACE +#include +#include +#include +#include +#include +#include + +#define EVENTCHN_PATH "/dev/xen/eventchn" + +static int eventchn_major = 10; +static int eventchn_minor = 61; + +static int do_ioctl(int handle, int cmd, void *arg) +{ + return ioctl(handle, cmd, arg); +} + +static int do_read_port(int handle, evtchn_port_t *port) +{ + return (read(handle, port, sizeof(evtchn_port_t)) != sizeof(evtchn_port_t)); +} + +static int do_write_port(int handle, evtchn_port_t port) +{ + return (write(handle, &port, sizeof(evtchn_port_t)) != sizeof(evtchn_port_t)); +} + +int eventchn_do_open(void) +{ + int fd; + + fd = open(EVENTCHN_PATH, O_RDWR); + if (fd == -1 && errno == ENOENT) { + mkdir("/dev/xen", 0640); + mknod(EVENTCHN_PATH, S_IFCHR | 0640, makedev(eventchn_major, eventchn_minor)); + fd = open(EVENTCHN_PATH, O_RDWR); + } + return fd; +} + +CAMLprim value stub_eventchn_init(value unit) +{ + CAMLparam1(unit); + int fd = eventchn_do_open(); + if (fd == -1) + caml_failwith("open failed"); + CAMLreturn(Val_int(fd)); +} + +CAMLprim value stub_eventchn_notify(value fd, value port) +{ + CAMLparam2(fd, port); + struct ioctl_evtchn_notify notify; + int rc; + + notify.port = Int_val(port); + rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_NOTIFY, ¬ify); + if (rc == -1) + caml_failwith("ioctl notify failed"); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_eventchn_bind_interdomain(value fd, value domid, + value remote_port) +{ + CAMLparam3(fd, domid, remote_port); + CAMLlocal1(port); + struct ioctl_evtchn_bind_interdomain bind; + int rc; + + bind.remote_domain = Int_val(domid); + bind.remote_port = Int_val(remote_port); + rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_INTERDOMAIN, &bind); + if (rc == -1) + caml_failwith("ioctl bind_interdomain failed"); + port = Val_int(rc); + + CAMLreturn(port); +} + +CAMLprim value stub_eventchn_bind_virq(value fd) +{ + CAMLparam1(fd); + CAMLlocal1(port); + struct ioctl_evtchn_bind_virq bind; + int rc; + + bind.virq = VIRQ_DOM_EXC; + rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_VIRQ, &bind); + if (rc == -1) + caml_failwith("ioctl bind_virq failed"); + port = Val_int(rc); + + CAMLreturn(port); +} + +CAMLprim value stub_eventchn_unbind(value fd, value port) +{ + CAMLparam2(fd, port); + struct ioctl_evtchn_unbind unbind; + int rc; + + unbind.port = Int_val(port); + rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_UNBIND, &unbind); + if (rc == -1) + caml_failwith("ioctl unbind failed"); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_eventchn_read_port(value fd) +{ + CAMLparam1(fd); + CAMLlocal1(result); + evtchn_port_t port; + + if (do_read_port(Int_val(fd), &port)) + caml_failwith("read port failed"); + result = Val_int(port); + + CAMLreturn(result); +} + +CAMLprim value stub_eventchn_write_port(value fd, value _port) +{ + CAMLparam2(fd, _port); + evtchn_port_t port; + + port = Int_val(_port); + if (do_write_port(Int_val(fd), port)) + caml_failwith("write port failed"); + CAMLreturn(Val_unit); +} diff --git a/tools/ocaml/libs/xb/META.in b/tools/ocaml/libs/xb/META.in new file mode 100644 index 0000000..c041010 --- /dev/null +++ b/tools/ocaml/libs/xb/META.in @@ -0,0 +1,4 @@ +version = "@VERSION@" +description = "XenBus Interface" +archive(byte) = "xb.cma" +archive(native) = "xb.cmxa" diff --git a/tools/ocaml/libs/xb/Makefile b/tools/ocaml/libs/xb/Makefile new file mode 100644 index 0000000..56afb4a --- /dev/null +++ b/tools/ocaml/libs/xb/Makefile @@ -0,0 +1,41 @@ +TOPLEVEL=../.. +include $(TOPLEVEL)/common.make + +CFLAGS += -I../mmap +OCAMLINCLUDE += -I ../mmap + +.NOTPARALLEL: +# Ocaml is such a PITA! + +PREINTF = op.cmi partial.cmi packet.cmi +PREOBJS = op partial packet xs_ring +PRELIBS = $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJBS),$(obj).cmx) +OBJS = op partial packet xs_ring xb +INTF = op.cmi packet.cmi xb.cmi +LIBS = xb.cma xb.cmxa + +ALL_OCAML_OBJS = $(OBJS) $(PREOJBS) + +all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +xb_OBJS = $(OBJS) +xb_C_OBJS = xs_ring_stubs xb_stubs +OCAML_LIBRARY = xb + +%.mli: %.ml + $(E) " MLI $@" + $(Q)$(OCAMLC) -i $< $o + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xb META $(INTF) $(LIBS) *.a *.so *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove xb + +include $(TOPLEVEL)/Makefile.rules diff --git a/tools/ocaml/libs/xb/op.ml b/tools/ocaml/libs/xb/op.ml new file mode 100644 index 0000000..6ea8fe6 --- /dev/null +++ b/tools/ocaml/libs/xb/op.ml @@ -0,0 +1,84 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type operation = Debug | Directory | Read | Getperms | + Watch | Unwatch | Transaction_start | + Transaction_end | Introduce | Release | + Getdomainpath | Write | Mkdir | Rm | + Setperms | Watchevent | Error | Isintroduced | + Resume | Set_target + | Restrict + +(* There are two sets of XB operations: the one coming from open-source and *) +(* the one coming from our private patch queue. These operations *) +(* in two differents arrays for make easier the forward compatibility *) +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 |] +let size = Array.length operation_c_mapping + +(* [offset_pq] has to be the same as in *) +let offset_pq = size +let operation_c_mapping_pq = + [| Restrict |] +let size_pq = Array.length operation_c_mapping_pq + +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 of_cval i = + if i >= 0 && i < size + then operation_c_mapping.(i) + else if i >= offset_pq && i < offset_pq + size_pq + then operation_c_mapping_pq.(i-offset_pq) + else raise Not_found + +let to_cval op = + try + array_search op operation_c_mapping + with _ -> offset_pq + array_search op operation_c_mapping_pq + +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" + | Restrict -> "RESTRICT" diff --git a/tools/ocaml/libs/xb/packet.ml b/tools/ocaml/libs/xb/packet.ml new file mode 100644 index 0000000..74c04bb --- /dev/null +++ b/tools/ocaml/libs/xb/packet.ml @@ -0,0 +1,50 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type t = +{ + 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" + +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) + +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 unpack pkt = + 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 get_rid pkt = pkt.rid \ No newline at end of file diff --git a/tools/ocaml/libs/xb/partial.ml b/tools/ocaml/libs/xb/partial.ml new file mode 100644 index 0000000..3558889 --- /dev/null +++ b/tools/ocaml/libs/xb/partial.ml @@ -0,0 +1,44 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type pkt = +{ + 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" + +let of_string s = + let tid, rid, opint, dlen = header_of_string_internal s in + { + tid = tid; + rid = rid; + ty = (Op.of_cval opint); + len = dlen; + buf = Buffer.create dlen; + } + +let append pkt s sz = + Buffer.add_string pkt.buf (String.sub s 0 sz) + +let to_complete pkt = + pkt.len - (Buffer.length pkt.buf) diff --git a/tools/ocaml/libs/xb/xb.ml b/tools/ocaml/libs/xb/xb.ml new file mode 100644 index 0000000..4d02376 --- /dev/null +++ b/tools/ocaml/libs/xb/xb.ml @@ -0,0 +1,189 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module Op = struct include Op end +module Packet = struct include Packet end + +exception End_of_file +exception Eagain +exception Noent +exception Invalid + +type backend_mmap = +{ + mmap: Mmap.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; +} + +type backend = Fd of backend_fd | Mmap of backend_mmap + +type partial_buf = HaveHdr of Partial.pkt | NoHdr of int * string + +type t = +{ + backend: backend; + pkt_in: Packet.t Queue.t; + pkt_out: Packet.t Queue.t; + mutable partial_in: partial_buf; + mutable partial_out: string; +} + +let init_partial_in () = NoHdr + (Partial.header_size (), String.make (Partial.header_size()) '\000') + +let queue con pkt = Queue.push pkt con.pkt_out + +let read_fd back con s len = + let rd = Unix.read back.fd s 0 len in + if rd = 0 then + raise End_of_file; + rd + +let read_mmap back con s len = + let rd = Xs_ring.read back.mmap s len in + back.work_again <- (rd > 0); + if rd > 0 then + back.eventchn_notify (); + rd + +let read con s len = + match con.backend with + | Fd backfd -> read_fd backfd con s len + | Mmap backmmap -> read_mmap backmmap con s len + +let write_fd back con s len = + Unix.write back.fd s 0 len + +let write_mmap back con s len = + let ws = Xs_ring.write 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 + | Mmap backmmap -> write_mmap backmmap con s len + +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 + Packet.to_string (Queue.pop con.pkt_out) + 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 = "" + +let input con = + let newpacket = ref false in + let to_read = + match con.partial_in with + | HaveHdr partial_pkt -> Partial.to_complete partial_pkt + | NoHdr (i, buf) -> i in + + (* try to get more data from input stream *) + let s = String.make to_read '\000' in + let sz = if to_read > 0 then read con s 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 s sz; + if Partial.to_complete partial_pkt = 0 then ( + let pkt = Packet.of_partialpkt partial_pkt in + con.partial_in <- init_partial_in (); + Queue.push pkt con.pkt_in; + newpacket := true + ) + | NoHdr (i, buf) -> + (* we complete the partial header *) + if sz > 0 then + String.blit s 0 buf (Partial.header_size () - i) sz; + con.partial_in <- if sz = i then + HaveHdr (Partial.of_string buf) else NoHdr (i - sz, buf) + ); + !newpacket + +let newcon backend = { + backend = backend; + pkt_in = Queue.create (); + pkt_out = Queue.create (); + partial_in = init_partial_in (); + partial_out = ""; + } + +let open_fd fd = newcon (Fd { fd = fd; }) + +let open_mmap mmap notifyfct = + newcon (Mmap { + mmap = mmap; + eventchn_notify = notifyfct; + work_again = false; }) + +let close con = + match con.backend with + | Fd backend -> Unix.close backend.fd + | Mmap backend -> Mmap.unmap backend.mmap + +let is_fd con = + match con.backend with + | Fd _ -> true + | Mmap _ -> false + +let is_mmap con = not (is_fd con) + +let output_len con = Queue.length con.pkt_out +let has_new_output con = Queue.length con.pkt_out > 0 +let has_old_output con = String.length con.partial_out > 0 + +let has_output con = has_new_output con || has_old_output con + +let peek_output con = Queue.peek con.pkt_out + +let input_len con = Queue.length con.pkt_in +let has_in_packet con = Queue.length con.pkt_in > 0 +let get_in_packet con = Queue.pop con.pkt_in +let has_more_input con = + match con.backend with + | Fd _ -> false + | Mmap backend -> backend.work_again + +let is_selectable con = + match con.backend with + | Fd _ -> true + | Mmap _ -> false + +let get_fd con = + match con.backend with + | Fd backend -> backend.fd + | Mmap _ -> raise (Failure "get_fd") diff --git a/tools/ocaml/libs/xb/xb.mli b/tools/ocaml/libs/xb/xb.mli new file mode 100644 index 0000000..6cbf0a8 --- /dev/null +++ b/tools/ocaml/libs/xb/xb.mli @@ -0,0 +1,83 @@ +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 + | Restrict + val to_string : operation -> string +end + +module Packet: +sig + type t + + exception Error of string + exception DataError of string + + val create : int -> int -> Op.operation -> string -> t + 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 +exception Invalid + +type t + +(** queue a packet into the output queue for later sending *) +val queue : t -> Packet.t -> unit + +(** process the output queue, return if a packet has been totally sent *) +val output : t -> bool + +(** process the input queue, return if a packet has been totally received *) +val input : t -> bool + +(** create new connection using a fd interface *) +val open_fd : Unix.file_descr -> t +(** create new connection using a mmap intf and a function to notify eventchn *) +val open_mmap : Mmap.mmap_interface -> (unit -> unit) -> t + +(* close a connection *) +val close : t -> unit + +val is_fd : t -> bool +val is_mmap : t -> bool + +val output_len : t -> int +val has_new_output : t -> bool +val has_old_output : t -> bool +val has_output : t -> bool +val peek_output : t -> Packet.t + +val input_len : t -> int +val has_in_packet : t -> bool +val get_in_packet : t -> Packet.t +val has_more_input : t -> bool + +val is_selectable : t -> bool +val get_fd : t -> Unix.file_descr diff --git a/tools/ocaml/libs/xb/xb_stubs.c b/tools/ocaml/libs/xb/xb_stubs.c new file mode 100644 index 0000000..b4d1ee6 --- /dev/null +++ b/tools/ocaml/libs/xb/xb_stubs.c @@ -0,0 +1,74 @@ +/* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + */ + +#include +#include +#include +#include +#include + +#include +#include +#include +#include +#include +#include + +#define __XEN_TOOLS__ + +#include +#define u32 uint32_t +#include + +CAMLprim value stub_header_size(void) +{ + CAMLparam0(); + CAMLreturn(Val_int(sizeof(struct xsd_sockmsg))); +} + +CAMLprim value stub_header_of_string(value s) +{ + CAMLparam1(s); + CAMLlocal1(ret); + struct xsd_sockmsg *hdr; + + if (caml_string_length(s) != sizeof(struct xsd_sockmsg)) + caml_failwith("xb header incomplete"); + ret = caml_alloc_tuple(4); + hdr = (struct xsd_sockmsg *) String_val(s); + Store_field(ret, 0, Val_int(hdr->tx_id)); + Store_field(ret, 1, Val_int(hdr->req_id)); + Store_field(ret, 2, Val_int(hdr->type)); + Store_field(ret, 3, Val_int(hdr->len)); + CAMLreturn(ret); +} + +CAMLprim value stub_string_of_header(value tid, value rid, value ty, value len) +{ + CAMLparam4(tid, rid, ty, len); + CAMLlocal1(ret); + struct xsd_sockmsg xsd = { + .type = Int_val(ty), + .tx_id = Int_val(tid), + .req_id = Int_val(rid), + .len = Int_val(len), + }; + + ret = caml_alloc_string(sizeof(struct xsd_sockmsg)); + memcpy(String_val(ret), &xsd, sizeof(struct xsd_sockmsg)); + + CAMLreturn(ret); +} diff --git a/tools/ocaml/libs/xb/xs_ring.ml b/tools/ocaml/libs/xb/xs_ring.ml new file mode 100644 index 0000000..00c18d5 --- /dev/null +++ b/tools/ocaml/libs/xb/xs_ring.ml @@ -0,0 +1,18 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +external read: Mmap.mmap_interface -> string -> int -> int = "ml_interface_read" +external write: Mmap.mmap_interface -> string -> int -> int = "ml_interface_write" diff --git a/tools/ocaml/libs/xb/xs_ring_stubs.c b/tools/ocaml/libs/xb/xs_ring_stubs.c new file mode 100644 index 0000000..9aef23e --- /dev/null +++ b/tools/ocaml/libs/xb/xs_ring_stubs.c @@ -0,0 +1,117 @@ +/* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + */ + +#include +#include +#include +#include +#include +#include + +#define __XEN_TOOLS__ + +#include +#define u32 uint32_t +#include + +#include +#include +#include +#include +#include +#include + +#include "mmap_stubs.h" + +#define GET_C_STRUCT(a) ((struct mmap_interface *) a) + +#ifndef xen_mb +#define xen_mb() mb() +#endif + +static int xs_ring_read(struct mmap_interface *interface, + char *buffer, int len) +{ + struct xenstore_domain_interface *intf = interface->addr; + XENSTORE_RING_IDX cons, prod; + int to_read; + + cons = intf->req_cons; + prod = intf->req_prod; + xen_mb(); + if (prod == cons) + return 0; + if (MASK_XENSTORE_IDX(prod) > MASK_XENSTORE_IDX(cons)) + to_read = prod - cons; + else + to_read = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(cons); + if (to_read < len) + len = to_read; + memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), len); + xen_mb(); + intf->req_cons += len; + return len; +} + +static int xs_ring_write(struct mmap_interface *interface, + char *buffer, int len) +{ + struct xenstore_domain_interface *intf = interface->addr; + XENSTORE_RING_IDX cons, prod; + int can_write; + + cons = intf->rsp_cons; + prod = intf->rsp_prod; + xen_mb(); + if ( (prod - cons) >= XENSTORE_RING_SIZE ) + return 0; + if (MASK_XENSTORE_IDX(prod) >= MASK_XENSTORE_IDX(cons)) + can_write = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(prod); + else + can_write = MASK_XENSTORE_IDX(cons) - MASK_XENSTORE_IDX(prod); + if (can_write < len) + len = can_write; + memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, len); + xen_mb(); + intf->rsp_prod += len; + return len; +} + +CAMLprim value ml_interface_read(value interface, value buffer, value len) +{ + CAMLparam3(interface, buffer, len); + CAMLlocal1(result); + int res; + + res = xs_ring_read(GET_C_STRUCT(interface), + String_val(buffer), Int_val(len)); + if (res == -1) + caml_failwith("huh"); + result = Val_int(res); + CAMLreturn(result); +} + +CAMLprim value ml_interface_write(value interface, value buffer, value len) +{ + CAMLparam3(interface, buffer, len); + CAMLlocal1(result); + int res; + + res = xs_ring_write(GET_C_STRUCT(interface), + String_val(buffer), Int_val(len)); + result = Val_int(res); + CAMLreturn(result); +} diff --git a/tools/ocaml/libs/xs/META.in b/tools/ocaml/libs/xs/META.in new file mode 100644 index 0000000..77d93b5 --- /dev/null +++ b/tools/ocaml/libs/xs/META.in @@ -0,0 +1,4 @@ +version = "@VERSION@" +description = "XenStore Interface" +archive(byte) = "xs.cma" +archive(native) = "xs.cmxa" diff --git a/tools/ocaml/libs/xs/Makefile b/tools/ocaml/libs/xs/Makefile new file mode 100644 index 0000000..87cd375 --- /dev/null +++ b/tools/ocaml/libs/xs/Makefile @@ -0,0 +1,42 @@ +TOPLEVEL=../.. +include $(TOPLEVEL)/common.make + +OCAMLINCLUDE += -I ../xb/ + +.NOTPARALLEL: +# Ocaml is such a PITA! + +PREINTF = xsraw.cmi xst.cmi +PREOBJS = queueop xsraw xst +PRELIBS = $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJBS),$(obj).cmx) +OBJS = queueop xsraw xst xs +INTF = xsraw.cmi xst.cmi xs.cmi +LIBS = xs.cma xs.cmxa + +all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +xs_OBJS = $(OBJS) +OCAML_NOC_LIBRARY = xs + +#xs.cmxa: $(foreach obj,$(OBJS),$(obj).cmx) +# $(E) " MLLIB $@" +# $(Q)$(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx) +# +#xs.cma: $(foreach obj,$(OBJS),$(obj).cmo) +# $(E) " MLLIB $@" +# $(Q)$(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo) + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xs META $(INTF) xs.mli xst.mli xsraw.mli $(LIBS) *.a *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove xs + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/xs/queueop.ml b/tools/ocaml/libs/xs/queueop.ml new file mode 100644 index 0000000..cb298f5 --- /dev/null +++ b/tools/ocaml/libs/xs/queueop.ml @@ -0,0 +1,73 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +let data_concat ls = (String.concat "\000" ls) ^ "\000" +let queue_path ty (tid: int) (path: string) con = + let data = data_concat [ path; ] in + Xb.queue con (Xb.Packet.create tid 0 ty data) + +(* operations *) +let directory tid path con = queue_path Xb.Op.Directory tid path con +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 = + Xb.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 + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Watch data) + +let unwatch path data con = + let data = data_concat [ path; data; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data) + +let transaction_start con = + Xb.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 + Xb.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 + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data) + +let release domid con = + let data = data_concat [ Printf.sprintf "%u" domid; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Release data) + +let resume domid con = + let data = data_concat [ Printf.sprintf "%u" domid; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Resume data) + +let getdomainpath domid con = + let data = data_concat [ Printf.sprintf "%u" domid; ] in + Xb.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 + Xb.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 + Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data) diff --git a/tools/ocaml/libs/xs/xs.ml b/tools/ocaml/libs/xs/xs.ml new file mode 100644 index 0000000..768778f --- /dev/null +++ b/tools/ocaml/libs/xs/xs.ml @@ -0,0 +1,170 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type perms = Xsraw.perms +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; +} + +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); +} + +let transaction xsh = Xst.transaction xsh.con + +let has_watchevents xsh = Xsraw.has_watchevents xsh.con +let get_watchevent xsh = Xsraw.get_watchevent xsh.con + +let read_watchevent xsh = Xsraw.read_watchevent xsh.con + +let make fd = get_operations (Xsraw.open_fd fd) +let get_fd xsh = Xb.get_fd xsh.con.Xsraw.xb + +exception Timeout + +(* Should never be thrown, indicates a bug in the read_watchevent_timetout function *) +exception Timeout_with_nonempty_queue + +(* Just in case we screw up: poll the callback every couple of seconds rather + than wait for the whole timeout period *) +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 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 + + (* 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 *) + + (* 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 + + +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 daemon_socket = "/var/run/xenstored/socket" + +(** Throws this rather than a miscellaneous Unix.connect failed *) +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 + +let domain_open () = + let path = "/proc/xen/xenbus" in + 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 diff --git a/tools/ocaml/libs/xs/xs.mli b/tools/ocaml/libs/xs/xs.mli new file mode 100644 index 0000000..ce505b6 --- /dev/null +++ b/tools/ocaml/libs/xs/xs.mli @@ -0,0 +1,90 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +exception Timeout + +(** Throws this rather than a miscellaneous Unix.connect failed *) +exception Failed_to_connect + +(** perms contains 3 things: + - 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; +} + +(** get operations provide a vector of xenstore function that apply to one + connection *) +val get_operations : con -> xsh + +(** create a transaction with a vector of function that can be applied + into the transaction. *) +val transaction : xsh -> (Xst.ops -> 'a) -> 'a + +(** watch manipulation on a connection *) +val has_watchevents : xsh -> bool +val get_watchevent : xsh -> string * string +val read_watchevent : xsh -> string * string + +(** get_fd return the fd of the connection to be able to select on it. + NOTE: it works only for socket-based connection *) +val get_fd : xsh -> Unix.file_descr + +(** wait for watchevent with a timeout. Until the callback return true, + every watch during the time specified, will be pass to the callback. + NOTE: it works only when use with a socket-based connection *) +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 + +(** open a socket-based xenstored connection *) +val daemon_open : unit -> xsh + +(** open a mmap-based xenstored connection *) +val domain_open : unit -> xsh + +(** close any xenstored connection *) +val close : xsh -> unit diff --git a/tools/ocaml/libs/xs/xsraw.ml b/tools/ocaml/libs/xs/xsraw.ml new file mode 100644 index 0000000..370d38e --- /dev/null +++ b/tools/ocaml/libs/xs/xsraw.ml @@ -0,0 +1,265 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +exception Partial_not_empty +exception Unexpected_packet of string + +(** Thrown when a path looks invalid e.g. if it contains "//" *) +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) + +type con = { + xb: Xb.t; + watchevents: (string * string) Queue.t; +} + +let close con = + Xb.close con.xb + +let open_fd fd = { + xb = Xb.open_fd 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) + +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 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, []) + +(* 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 + +(* receive one packet - can sleep *) +let pkt_recv con = + let workdone = ref false in + while not !workdone + do + workdone := Xb.input con.xb + done; + Xb.get_in_packet con.xb + +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 ( + let workdone = Xb.input con.xb in + if workdone then + false, (Some (Xb.get_in_packet con.xb)) + else + false, None + ) + +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 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 + +(* 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 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 + +let ack 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) + +(** 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 + +let 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 + +let 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) + +let 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) + +let 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 transaction_end tid commit con = + 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) + +let release domid con = + ack (sync (Queueop.release domid) con) + +let resume domid con = + ack (sync (Queueop.resume domid) con) + +let 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) + +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 + +let 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 -> () + +let setperms tid path 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 diff --git a/tools/ocaml/libs/xs/xsraw.mli b/tools/ocaml/libs/xs/xsraw.mli new file mode 100644 index 0000000..42f87b6 --- /dev/null +++ b/tools/ocaml/libs/xs/xsraw.mli @@ -0,0 +1,60 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +exception Partial_not_empty +exception Unexpected_packet of string +exception Invalid_path of string +val unexpected_packet : Xb.Op.operation -> Xb.Op.operation -> 'a +type con = { xb : Xb.t; watchevents : (string * string) Queue.t; } +val close : con -> unit +val open_fd : Unix.file_descr -> con +val split_string : ?limit:int -> char -> string -> string list +type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR +type perms = int * perm * (int * perm) list +val string_of_perms : int * perm * (int * perm) list -> string +val perms_of_string : string -> int * perm * (int * perm) list +val pkt_send : con -> unit +val pkt_recv : con -> Xb.Packet.t +val pkt_recv_timeout : con -> float -> bool * Xb.Packet.t option +val queue_watchevent : con -> string -> unit +val has_watchevents : con -> bool +val get_watchevent : con -> string * string +val read_watchevent : con -> string * string +val sync_recv : Xb.Op.operation -> con -> string +val sync : (Xb.t -> 'a) -> con -> string +val ack : string -> unit +val validate_path : string -> unit +val validate_watch_path : string -> unit +val directory : int -> string -> con -> string list +val debug : string list -> con -> string +val read : int -> string -> con -> string +val readv : int -> string -> string list -> con -> string list +val getperms : int -> string -> con -> int * perm * (int * perm) list +val watch : string -> string -> con -> unit +val unwatch : string -> string -> con -> unit +val transaction_start : con -> int +val transaction_end : int -> bool -> con -> bool +val introduce : int -> nativeint -> int -> con -> unit +val release : int -> con -> unit +val resume : int -> con -> unit +val getdomainpath : int -> con -> string +val write : int -> string -> string -> con -> unit +val writev : int -> string -> (string * string) list -> con -> unit +val mkdir : int -> string -> con -> unit +val rm : int -> string -> con -> unit +val setperms : int -> string -> int * perm * (int * perm) list -> con -> unit +val setpermsv : + int -> + string -> string list -> int * perm * (int * perm) list -> con -> unit diff --git a/tools/ocaml/libs/xs/xst.ml b/tools/ocaml/libs/xs/xst.ml new file mode 100644 index 0000000..16affd2 --- /dev/null +++ b/tools/ocaml/libs/xs/xst.ml @@ -0,0 +1,61 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type 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; +} + +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); +} + +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 + + 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 diff --git a/tools/ocaml/libs/xs/xst.mli b/tools/ocaml/libs/xs/xst.mli new file mode 100644 index 0000000..5ae5604 --- /dev/null +++ b/tools/ocaml/libs/xs/xst.mli @@ -0,0 +1,30 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +type 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; +} + +val get_operations : int -> Xsraw.con -> ops +val transaction : Xsraw.con -> (ops -> 'a) -> 'a