From mboxrd@z Thu Jan 1 00:00:00 1970 From: Vincent Hanquez Subject: [PATCH 03/10] add XS ocaml bindings. Date: Fri, 23 Apr 2010 15:31:46 +0100 Message-ID: <1272033113-23829-4-git-send-email-vincent.hanquez@eu.citrix.com> References: <1272033113-23829-1-git-send-email-vincent.hanquez@eu.citrix.com> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="------------1.7.0.4" Return-path: In-Reply-To: <1272033113-23829-1-git-send-email-vincent.hanquez@eu.citrix.com> List-Unsubscribe: , List-Post: List-Help: List-Subscribe: , Sender: xen-devel-bounces@lists.xensource.com Errors-To: xen-devel-bounces@lists.xensource.com To: xen-devel Cc: Vincent Hanquez List-Id: xen-devel@lists.xenproject.org --------------1.7.0.4 Content-Type: text/plain; charset="UTF-8"; format=fixed Content-Transfer-Encoding: quoted-printable Signed-off-by: Vincent Hanquez --- tools/ocaml/libs/eventchn/META.in | 4 + tools/ocaml/libs/eventchn/Makefile | 28 +++ tools/ocaml/libs/eventchn/eventchn.ml | 27 +++ tools/ocaml/libs/eventchn/eventchn.mli | 26 +++ tools/ocaml/libs/eventchn/eventchn_stubs.c | 173 ++++++++++++++++++ tools/ocaml/libs/xb/META.in | 4 + tools/ocaml/libs/xb/Makefile | 41 +++++ tools/ocaml/libs/xb/op.ml | 84 +++++++++ tools/ocaml/libs/xb/packet.ml | 50 ++++++ tools/ocaml/libs/xb/partial.ml | 44 +++++ tools/ocaml/libs/xb/xb.ml | 189 ++++++++++++++++++++ tools/ocaml/libs/xb/xb.mli | 83 +++++++++ tools/ocaml/libs/xb/xb_stubs.c | 74 ++++++++ tools/ocaml/libs/xb/xs_ring.ml | 18 ++ tools/ocaml/libs/xb/xs_ring_stubs.c | 117 ++++++++++++ tools/ocaml/libs/xs/META.in | 4 + tools/ocaml/libs/xs/Makefile | 42 +++++ tools/ocaml/libs/xs/queueop.ml | 73 ++++++++ tools/ocaml/libs/xs/xs.ml | 170 ++++++++++++++++++ tools/ocaml/libs/xs/xs.mli | 90 ++++++++++ tools/ocaml/libs/xs/xsraw.ml | 265 ++++++++++++++++++++++= ++++++ tools/ocaml/libs/xs/xsraw.mli | 60 +++++++ tools/ocaml/libs/xs/xst.ml | 61 +++++++ tools/ocaml/libs/xs/xst.mli | 30 +++ 24 files changed, 1757 insertions(+), 0 deletions(-) create mode 100644 tools/ocaml/libs/eventchn/META.in create mode 100644 tools/ocaml/libs/eventchn/Makefile create mode 100644 tools/ocaml/libs/eventchn/eventchn.ml create mode 100644 tools/ocaml/libs/eventchn/eventchn.mli create mode 100644 tools/ocaml/libs/eventchn/eventchn_stubs.c create mode 100644 tools/ocaml/libs/xb/META.in create mode 100644 tools/ocaml/libs/xb/Makefile create mode 100644 tools/ocaml/libs/xb/op.ml create mode 100644 tools/ocaml/libs/xb/packet.ml create mode 100644 tools/ocaml/libs/xb/partial.ml create mode 100644 tools/ocaml/libs/xb/xb.ml create mode 100644 tools/ocaml/libs/xb/xb.mli create mode 100644 tools/ocaml/libs/xb/xb_stubs.c create mode 100644 tools/ocaml/libs/xb/xs_ring.ml create mode 100644 tools/ocaml/libs/xb/xs_ring_stubs.c create mode 100644 tools/ocaml/libs/xs/META.in create mode 100644 tools/ocaml/libs/xs/Makefile create mode 100644 tools/ocaml/libs/xs/queueop.ml create mode 100644 tools/ocaml/libs/xs/xs.ml create mode 100644 tools/ocaml/libs/xs/xs.mli create mode 100644 tools/ocaml/libs/xs/xsraw.ml create mode 100644 tools/ocaml/libs/xs/xsraw.mli create mode 100644 tools/ocaml/libs/xs/xst.ml create mode 100644 tools/ocaml/libs/xs/xst.mli --------------1.7.0.4 Content-Type: text/x-patch; name="0003-add-XS-ocaml-bindings.patch" Content-Disposition: attachment; filename="0003-add-XS-ocaml-bindings.patch" Content-Transfer-Encoding: quoted-printable diff --git a/tools/ocaml/libs/eventchn/META.in b/tools/ocaml/libs/eventch= n/META.in new file mode 100644 index 0000000..f3e01aa --- /dev/null +++ b/tools/ocaml/libs/eventchn/META.in @@ -0,0 +1,4 @@ +version =3D "@VERSION@" +description =3D "Eventchn interface extension" +archive(byte) =3D "eventchn.cma" +archive(native) =3D "eventchn.cmxa" diff --git a/tools/ocaml/libs/eventchn/Makefile b/tools/ocaml/libs/eventc= hn/Makefile new file mode 100644 index 0000000..9d6ef31 --- /dev/null +++ b/tools/ocaml/libs/eventchn/Makefile @@ -0,0 +1,28 @@ +TOPLEVEL=3D../.. +include $(TOPLEVEL)/common.make + +OBJS =3D eventchn +INTF =3D $(foreach obj, $(OBJS),$(obj).cmi) +LIBS =3D eventchn.cma eventchn.cmxa + +all: $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +eventchn_OBJS =3D $(OBJS) +eventchn_C_OBJS =3D eventchn_stubs + +OCAML_LIBRARY =3D eventchn + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdi= r) -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/eve= ntchn/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 publis= hed + * 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 =3D "stub_eventchn_init" +external notify: Unix.file_descr -> int -> unit =3D "stub_eventchn_notif= y" +external bind_interdomain: Unix.file_descr -> int -> int -> int =3D "stu= b_eventchn_bind_interdomain" +external bind_virq: Unix.file_descr -> int =3D "stub_eventchn_bind_virq" +external unbind: Unix.file_descr -> int -> unit =3D "stub_eventchn_unbin= d" +external read_port: Unix.file_descr -> int =3D "stub_eventchn_read_port" +external write_port: Unix.file_descr -> int -> unit =3D "stub_eventchn_w= rite_port" + +let _ =3D Callback.register_exception "eventchn.error" (Error "register_= callback") diff --git a/tools/ocaml/libs/eventchn/eventchn.mli b/tools/ocaml/libs/ev= entchn/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 publis= hed + * 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 =3D "stub_eventchn_init" +external notify : Unix.file_descr -> int -> unit =3D "stub_eventchn_noti= fy" +external bind_interdomain : Unix.file_descr -> int -> int -> int + =3D "stub_eventchn_bind_interdomain" +external bind_virq : Unix.file_descr -> int =3D "stub_eventchn_bind_virq= " +external unbind : Unix.file_descr -> int -> unit =3D "stub_eventchn_unbi= nd" +external read_port : Unix.file_descr -> int =3D "stub_eventchn_read_port= " +external write_port : Unix.file_descr -> int -> unit + =3D "stub_eventchn_write_port" diff --git a/tools/ocaml/libs/eventchn/eventchn_stubs.c b/tools/ocaml/lib= s/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 publis= hed + * 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 =3D 10; +static int eventchn_minor =3D 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)) !=3D sizeof(evtchn_po= rt_t)); +} + +static int do_write_port(int handle, evtchn_port_t port) +{ + return (write(handle, &port, sizeof(evtchn_port_t)) !=3D sizeof(evtchn_= port_t)); +} + +int eventchn_do_open(void) +{ + int fd; + + fd =3D open(EVENTCHN_PATH, O_RDWR); + if (fd =3D=3D -1 && errno =3D=3D ENOENT) { + mkdir("/dev/xen", 0640); + mknod(EVENTCHN_PATH, S_IFCHR | 0640, makedev(eventchn_major, eventchn_= minor)); + fd =3D open(EVENTCHN_PATH, O_RDWR); + } + return fd; +} + +CAMLprim value stub_eventchn_init(value unit) +{ + CAMLparam1(unit); + int fd =3D eventchn_do_open(); + if (fd =3D=3D -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 =3D Int_val(port); + rc =3D do_ioctl(Int_val(fd), IOCTL_EVTCHN_NOTIFY, ¬ify); + if (rc =3D=3D -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 =3D Int_val(domid); + bind.remote_port =3D Int_val(remote_port); + rc =3D do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_INTERDOMAIN, &bind); + if (rc =3D=3D -1) + caml_failwith("ioctl bind_interdomain failed"); + port =3D 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 =3D VIRQ_DOM_EXC; + rc =3D do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_VIRQ, &bind); + if (rc =3D=3D -1) + caml_failwith("ioctl bind_virq failed"); + port =3D 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 =3D Int_val(port); + rc =3D do_ioctl(Int_val(fd), IOCTL_EVTCHN_UNBIND, &unbind); + if (rc =3D=3D -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 =3D Val_int(port); + + CAMLreturn(result); +} + +CAMLprim value stub_eventchn_write_port(value fd, value _port) +{ + CAMLparam2(fd, _port); + evtchn_port_t port; + + port =3D 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 =3D "@VERSION@" +description =3D "XenBus Interface" +archive(byte) =3D "xb.cma" +archive(native) =3D "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=3D../.. +include $(TOPLEVEL)/common.make + +CFLAGS +=3D -I../mmap +OCAMLINCLUDE +=3D -I ../mmap + +.NOTPARALLEL: +# Ocaml is such a PITA! + +PREINTF =3D op.cmi partial.cmi packet.cmi +PREOBJS =3D op partial packet xs_ring +PRELIBS =3D $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJB= S),$(obj).cmx) +OBJS =3D op partial packet xs_ring xb +INTF =3D op.cmi packet.cmi xb.cmi +LIBS =3D xb.cma xb.cmxa + +ALL_OCAML_OBJS =3D $(OBJS) $(PREOJBS) + +all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +xb_OBJS =3D $(OBJS) +xb_C_OBJS =3D xs_ring_stubs xb_stubs +OCAML_LIBRARY =3D xb + +%.mli: %.ml + $(E) " MLI $@" + $(Q)$(OCAMLC) -i $< $o + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdi= r) -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 publis= hed + * 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 =3D Debug | Directory | Read | Getperms | + Watch | Unwatch | Transaction_start | + Transaction_end | Introduce | Release | + Getdomainpath | Write | Mkdir | Rm | + Setperms | Watchevent | Error | Isintroduced | + Resume | Set_target + | Restrict=20 + +(* 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 =3D + [| 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 =3D Array.length operation_c_mapping + +(* [offset_pq] has to be the same as in *) +let offset_pq =3D size +let operation_c_mapping_pq =3D + [| Restrict |] +let size_pq =3D Array.length operation_c_mapping_pq + +let array_search el a =3D + let len =3D Array.length a in + let rec search i =3D + if i > len then raise Not_found; + if a.(i) =3D el then i else search (i + 1) in + search 0 + +let of_cval i =3D + if i >=3D 0 && i < size + then operation_c_mapping.(i) + else if i >=3D offset_pq && i < offset_pq + size_pq + then operation_c_mapping_pq.(i-offset_pq) + else raise Not_found + +let to_cval op =3D + try + array_search op operation_c_mapping + with _ -> offset_pq + array_search op operation_c_mapping_pq + +let to_string ty =3D + 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.m= l 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 publis= hed + * 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 =3D +{ + 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 =3D "stub_= string_of_header" + +let create tid rid ty data =3D { tid =3D tid; rid =3D rid; ty =3D ty; da= ta =3D data; } + +let of_partialpkt ppkt =3D + create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.conten= ts ppkt.Partial.buf) + +let to_string pkt =3D + let header =3D string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (St= ring.length pkt.data) in + header ^ pkt.data + +let unpack pkt =3D + pkt.tid, pkt.rid, pkt.ty, pkt.data + +let get_tid pkt =3D pkt.tid +let get_ty pkt =3D pkt.ty +let get_data pkt =3D + let l =3D String.length pkt.data in + if l > 0 && pkt.data.[l - 1] =3D '\000' then + String.sub pkt.data 0 (l - 1) + else + pkt.data +let get_rid pkt =3D 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 publis= hed + * 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 =3D +{ + tid: int; + rid: int; + ty: Op.operation; + len: int; + buf: Buffer.t; +} + +external header_size: unit -> int =3D "stub_header_size" +external header_of_string_internal: string -> int * int * int * int + =3D "stub_header_of_string" + +let of_string s =3D + let tid, rid, opint, dlen =3D header_of_string_internal s in + { + tid =3D tid; + rid =3D rid; + ty =3D (Op.of_cval opint); + len =3D dlen; + buf =3D Buffer.create dlen; + } + +let append pkt s sz =3D + Buffer.add_string pkt.buf (String.sub s 0 sz) + +let to_complete pkt =3D + 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 publis= hed + * 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 =3D struct include Op end +module Packet =3D struct include Packet end + +exception End_of_file +exception Eagain +exception Noent +exception Invalid + +type backend_mmap =3D +{ + mmap: Mmap.mmap_interface; (* mmaped interface =3D xs_ring *) + eventchn_notify: unit -> unit; (* function to notify through eventchn *= ) + mutable work_again: bool; +} + +type backend_fd =3D +{ + fd: Unix.file_descr; +} + +type backend =3D Fd of backend_fd | Mmap of backend_mmap + +type partial_buf =3D HaveHdr of Partial.pkt | NoHdr of int * string + +type t =3D +{ + 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 () =3D NoHdr + (Partial.header_size (), String.make (Partial.header_size()) '\000') + +let queue con pkt =3D Queue.push pkt con.pkt_out + +let read_fd back con s len =3D + let rd =3D Unix.read back.fd s 0 len in + if rd =3D 0 then + raise End_of_file; + rd + +let read_mmap back con s len =3D + let rd =3D 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 =3D + 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 =3D + Unix.write back.fd s 0 len + +let write_mmap back con s len =3D + let ws =3D Xs_ring.write back.mmap s len in + if ws > 0 then + back.eventchn_notify (); + ws + +let write con s len =3D + match con.backend with + | Fd backfd -> write_fd backfd con s len + | Mmap backmmap -> write_mmap backmmap con s len + +let output con =3D + (* get the output string from a string_of(packet) or partial_out *) + let s =3D 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 =3D String.length s in + let sz =3D write con s len in + let left =3D String.sub s sz (len - sz) in + con.partial_out <- left + ); + (* after sending one packet, partial is empty *) + con.partial_out =3D "" + +let input con =3D + let newpacket =3D ref false in + let to_read =3D + 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 =3D String.make to_read '\000' in + let sz =3D 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 =3D 0 then ( + let pkt =3D Packet.of_partialpkt partial_pkt in + con.partial_in <- init_partial_in (); + Queue.push pkt con.pkt_in; + newpacket :=3D 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 =3D i then + HaveHdr (Partial.of_string buf) else NoHdr (i - sz, buf) + ); + !newpacket + +let newcon backend =3D { + backend =3D backend; + pkt_in =3D Queue.create (); + pkt_out =3D Queue.create (); + partial_in =3D init_partial_in (); + partial_out =3D ""; + } + +let open_fd fd =3D newcon (Fd { fd =3D fd; }) + +let open_mmap mmap notifyfct =3D + newcon (Mmap { + mmap =3D mmap; + eventchn_notify =3D notifyfct; + work_again =3D false; }) + +let close con =3D + match con.backend with + | Fd backend -> Unix.close backend.fd + | Mmap backend -> Mmap.unmap backend.mmap + +let is_fd con =3D + match con.backend with + | Fd _ -> true + | Mmap _ -> false + +let is_mmap con =3D not (is_fd con) + +let output_len con =3D Queue.length con.pkt_out +let has_new_output con =3D Queue.length con.pkt_out > 0 +let has_old_output con =3D String.length con.partial_out > 0 + +let has_output con =3D has_new_output con || has_old_output con + +let peek_output con =3D Queue.peek con.pkt_out + +let input_len con =3D Queue.length con.pkt_in +let has_in_packet con =3D Queue.length con.pkt_in > 0 +let get_in_packet con =3D Queue.pop con.pkt_in +let has_more_input con =3D + match con.backend with + | Fd _ -> false + | Mmap backend -> backend.work_again + +let is_selectable con =3D + match con.backend with + | Fd _ -> true + | Mmap _ -> false + +let get_fd con =3D + 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 =3D Op.operation =3D + | 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 receive= d *) +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 eve= ntchn *) +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_stub= s.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 publis= hed + * 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) !=3D sizeof(struct xsd_sockmsg)) + caml_failwith("xb header incomplete"); + ret =3D caml_alloc_tuple(4); + hdr =3D (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, val= ue len) +{ + CAMLparam4(tid, rid, ty, len); + CAMLlocal1(ret); + struct xsd_sockmsg xsd =3D { + .type =3D Int_val(ty), + .tx_id =3D Int_val(tid), + .req_id =3D Int_val(rid), + .len =3D Int_val(len), + }; + + ret =3D 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 publis= hed + * 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 =3D "ml_inter= face_read" +external write: Mmap.mmap_interface -> string -> int -> int =3D "ml_inte= rface_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 publis= hed + * 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 =3D interface->addr; + XENSTORE_RING_IDX cons, prod; + int to_read; + + cons =3D intf->req_cons; + prod =3D intf->req_prod; + xen_mb(); + if (prod =3D=3D cons) + return 0; + if (MASK_XENSTORE_IDX(prod) > MASK_XENSTORE_IDX(cons))=20 + to_read =3D prod - cons; + else + to_read =3D XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(cons); + if (to_read < len) + len =3D to_read; + memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), len); + xen_mb(); + intf->req_cons +=3D len; + return len; +} + +static int xs_ring_write(struct mmap_interface *interface, + char *buffer, int len) +{ + struct xenstore_domain_interface *intf =3D interface->addr; + XENSTORE_RING_IDX cons, prod; + int can_write; + + cons =3D intf->rsp_cons; + prod =3D intf->rsp_prod; + xen_mb(); + if ( (prod - cons) >=3D XENSTORE_RING_SIZE ) + return 0; + if (MASK_XENSTORE_IDX(prod) >=3D MASK_XENSTORE_IDX(cons)) + can_write =3D XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(prod); + else=20 + can_write =3D MASK_XENSTORE_IDX(cons) - MASK_XENSTORE_IDX(prod); + if (can_write < len) + len =3D can_write; + memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, len); + xen_mb(); + intf->rsp_prod +=3D len; + return len; +} + +CAMLprim value ml_interface_read(value interface, value buffer, value le= n) +{ + CAMLparam3(interface, buffer, len); + CAMLlocal1(result); + int res; + + res =3D xs_ring_read(GET_C_STRUCT(interface), + String_val(buffer), Int_val(len)); + if (res =3D=3D -1) + caml_failwith("huh"); + result =3D Val_int(res); + CAMLreturn(result); +} + +CAMLprim value ml_interface_write(value interface, value buffer, value l= en) +{ + CAMLparam3(interface, buffer, len); + CAMLlocal1(result); + int res; + + res =3D xs_ring_write(GET_C_STRUCT(interface), + String_val(buffer), Int_val(len)); + result =3D 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 =3D "@VERSION@" +description =3D "XenStore Interface" +archive(byte) =3D "xs.cma" +archive(native) =3D "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=3D../.. +include $(TOPLEVEL)/common.make + +OCAMLINCLUDE +=3D -I ../xb/ + +.NOTPARALLEL: +# Ocaml is such a PITA! + +PREINTF =3D xsraw.cmi xst.cmi +PREOBJS =3D queueop xsraw xst +PRELIBS =3D $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJB= S),$(obj).cmx) +OBJS =3D queueop xsraw xst xs +INTF =3D xsraw.cmi xst.cmi xs.cmi +LIBS =3D xs.cma xs.cmxa + +all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +xs_OBJS =3D $(OBJS) +OCAML_NOC_LIBRARY =3D 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 destdi= r) -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 publis= hed + * 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 =3D (String.concat "\000" ls) ^ "\000" +let queue_path ty (tid: int) (path: string) con =3D + let data =3D data_concat [ path; ] in + Xb.queue con (Xb.Packet.create tid 0 ty data) + +(* operations *) +let directory tid path con =3D queue_path Xb.Op.Directory tid path con +let read tid path con =3D queue_path Xb.Op.Read tid path con + +let getperms tid path con =3D queue_path Xb.Op.Getperms tid path con + +let debug commands con =3D + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands)) + +let watch path data con =3D + let data =3D data_concat [ path; data; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Watch data) + +let unwatch path data con =3D + let data =3D data_concat [ path; data; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data) + +let transaction_start con =3D + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat= [])) + +let transaction_end tid commit con =3D + let data =3D 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 =3D + let data =3D 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 =3D + let data =3D data_concat [ Printf.sprintf "%u" domid; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Release data) + +let resume domid con =3D + let data =3D data_concat [ Printf.sprintf "%u" domid; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Resume data) + +let getdomainpath domid con =3D + let data =3D 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 =3D + let data =3D 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 =3D queue_path Xb.Op.Mkdir tid path con +let rm tid path con =3D queue_path Xb.Op.Rm tid path con + +let setperms tid path perms con =3D + let data =3D 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 publis= hed + * 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 =3D Xsraw.perms +type con =3D Xsraw.con +type domid =3D int + +type xsh =3D +{ + 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 =3D { + con =3D con; + debug =3D (fun commands -> Xsraw.debug commands con); + directory =3D (fun path -> Xsraw.directory 0 path con); + read =3D (fun path -> Xsraw.read 0 path con); + readv =3D (fun dir vec -> Xsraw.readv 0 dir vec con); + write =3D (fun path value -> Xsraw.write 0 path value con); + writev =3D (fun dir vec -> Xsraw.writev 0 dir vec con); + mkdir =3D (fun path -> Xsraw.mkdir 0 path con); + rm =3D (fun path -> Xsraw.rm 0 path con); + getperms =3D (fun path -> Xsraw.getperms 0 path con); + setperms =3D (fun path perms -> Xsraw.setperms 0 path perms con); + setpermsv =3D (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con= ); + introduce =3D (fun id mfn port -> Xsraw.introduce id mfn port con); + release =3D (fun id -> Xsraw.release id con); + resume =3D (fun id -> Xsraw.resume id con); + getdomainpath =3D (fun id -> Xsraw.getdomainpath id con); + watch =3D (fun path data -> Xsraw.watch path data con); + unwatch =3D (fun path data -> Xsraw.unwatch path data con); +} + +let transaction xsh =3D Xst.transaction xsh.con + +let has_watchevents xsh =3D Xsraw.has_watchevents xsh.con +let get_watchevent xsh =3D Xsraw.get_watchevent xsh.con + +let read_watchevent xsh =3D Xsraw.read_watchevent xsh.con + +let make fd =3D get_operations (Xsraw.open_fd fd) +let get_fd xsh =3D Xb.get_fd xsh.con.Xsraw.xb + +exception Timeout + +(* Should never be thrown, indicates a bug in the read_watchevent_timeto= ut function *) +exception Timeout_with_nonempty_queue + +(* Just in case we screw up: poll the callback every couple of seconds r= ather + than wait for the whole timeout period *) +let max_blocking_time =3D 5. (* seconds *) + +let read_watchevent_timeout xsh timeout callback =3D + let start_time =3D Unix.gettimeofday () in + let end_time =3D start_time +. timeout in + + let left =3D ref timeout in + + (* Returns true if a watch event in the queue satisfied us *) + let process_queued_events () =3D=20 + let success =3D ref false in + while Xsraw.has_watchevents xsh.con && not(!success) + do + success :=3D 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 () =3D=20 + let fd =3D get_fd xsh in + let r, _, _ =3D Unix.select [ fd ] [] [] (min max_blocking_time !left)= in + + (* If data is available for reading then read it *) + if r =3D [] + then false (* timeout, either a max_blocking_time or global *) + else callback (Xsraw.read_watchevent xsh.con) in + + let success =3D 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 :=3D process_queued_events (); + (* Then block for one more watch event *) + if not(!success) + then success :=3D 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 :=3D process_queued_events (); + + (* Update the time left *) + let current_time =3D Unix.gettimeofday () in + left :=3D 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 =3D + let unwatch () =3D + 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 =3D "/var/run/xenstored/socket" + +(** Throws this rather than a miscellaneous Unix.connect failed *) +exception Failed_to_connect + +let daemon_open () =3D + try + let sockaddr =3D Unix.ADDR_UNIX(daemon_socket) in + let sock =3D 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 () =3D + let path =3D "/proc/xen/xenbus" in + let fd =3D Unix.openfile path [ Unix.O_RDWR ] 0o550 in + Unix.set_close_on_exec fd; + make fd + +let close xsh =3D 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 publis= hed + * 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 =3D Xsraw.perms + +type domid =3D int +type con + +type xsh =3D { + 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 o= ne + 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 publis= hed + * 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 =3D + let s =3D Printf.sprintf "expecting %s received %s" + (Xb.Op.to_string expected) + (Xb.Op.to_string received) in + raise (Unexpected_packet s) + +type con =3D { + xb: Xb.t; + watchevents: (string * string) Queue.t; +} + +let close con =3D + Xb.close con.xb + +let open_fd fd =3D { + xb =3D Xb.open_fd fd; + watchevents =3D Queue.create (); +} + +let rec split_string ?limit:(limit=3D(-1)) c s =3D + let i =3D try String.index s c with Not_found -> -1 in + let nlimit =3D if limit =3D -1 || limit =3D 0 then limit else limit - 1= in + if i =3D -1 || nlimit =3D 0 then + [ s ] + else + let a =3D String.sub s 0 i + and b =3D String.sub s (i + 1) (String.length s - i - 1) in + a :: (split_string ~limit: nlimit c b) + +type perm =3D PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR + +type perms =3D int * perm * (int * perm) list + +let string_of_perms perms =3D + let owner, other, acl =3D perms in + let char_of_perm perm =3D + match perm with PERM_NONE -> 'n' | PERM_READ -> 'r' + | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in + let string_of_perm (id, perm) =3D Printf.sprintf "%c%u" (char_of_perm p= erm) id in + String.concat "\000" (List.map string_of_perm ((owner,other) :: acl)) + +let perms_of_string s =3D + let perm_of_char c =3D + 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 =3D + if String.length s < 2=20 + then invalid_arg (Printf.sprintf "perm of string: length =3D %d; conte= nts=3D\"%s\"" (String.length s) s)=20 + else + begin + int_of_string (String.sub s 1 (String.length s - 1)), + perm_of_char s.[0] + end in + let rec split s =3D + try let i =3D 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 =3D "" then [] else [ s ] in + let l =3D 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 =3D + if Xb.has_old_output con.xb then + raise Partial_not_empty; + let workdone =3D ref false in + while not !workdone + do + workdone :=3D Xb.output con.xb + done + +(* receive one packet - can sleep *) +let pkt_recv con =3D + let workdone =3D ref false in + while not !workdone + do + workdone :=3D Xb.input con.xb + done; + Xb.get_in_packet con.xb + +let pkt_recv_timeout con timeout =3D + let fd =3D Xb.get_fd con.xb in + let r, _, _ =3D Unix.select [ fd ] [] [] timeout in + if r =3D [] then + true, None + else ( + let workdone =3D Xb.input con.xb in + if workdone then + false, (Some (Xb.get_in_packet con.xb)) + else + false, None + ) + +let queue_watchevent con data =3D + let ls =3D split_string ~limit:2 '\000' data in + if List.length ls !=3D 2 then + raise (Xb.Packet.DataError "arguments number mismatch"); + let event =3D List.nth ls 0 + and event_data =3D List.nth ls 1 in + Queue.push (event, event_data) con.watchevents + +let has_watchevents con =3D Queue.length con.watchevents > 0 +let get_watchevent con =3D Queue.pop con.watchevents + +let read_watchevent con =3D + let pkt =3D 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 =3D + let pkt =3D 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 =3D ty -> Xb.Packet.get_data pkt + | rty -> unexpected_packet ty rty + +let sync f con =3D + (* queue a query using function f *) + f con.xb; + if Xb.output_len con.xb =3D 0 then + Printf.printf "output len =3D 0\n%!"; + let ty =3D Xb.Packet.get_ty (Xb.peek_output con.xb) in + pkt_send con; + sync_recv ty con + +let ack s =3D + if s =3D "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 =3D + (* Paths shouldn't have a "//" in the middle *) + let bad =3D "//" in + for offset =3D 0 to String.length path - (String.length bad) do + if String.sub path offset (String.length bad) =3D 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] =3D '/' t= hen + raise (Invalid_path path) + +(** Check to see if a path is suitable for watches *) +let validate_watch_path path =3D + (* Check for stuff like @releaseDomain etc first *) + if path <> "" && path.[0] =3D '@' then () + else validate_path path + +let debug command con =3D + sync (Queueop.debug command) con + +let directory tid path con =3D + validate_path path; + let data =3D sync (Queueop.directory tid path) con in + split_string '\000' data + +let read tid path con =3D + validate_path path; + sync (Queueop.read tid path) con + +let readv tid dir vec con =3D + 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 =3D + validate_path path; + perms_of_string (sync (Queueop.getperms tid path) con) + +let watch path data con =3D + validate_watch_path path; + ack (sync (Queueop.watch path data) con) + +let unwatch path data con =3D + validate_watch_path path; + ack (sync (Queueop.unwatch path data) con) + +let transaction_start con =3D + let data =3D 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 =3D + try + ack (sync (Queueop.transaction_end tid commit) con); + true + with + Xb.Eagain -> false + +let introduce domid mfn port con =3D + ack (sync (Queueop.introduce domid mfn port) con) + +let release domid con =3D + ack (sync (Queueop.release domid) con) + +let resume domid con =3D + ack (sync (Queueop.resume domid) con) + +let getdomainpath domid con =3D + sync (Queueop.getdomainpath domid) con + +let write tid path value con =3D + validate_path path; + ack (sync (Queueop.write tid path value) con) + +let writev tid dir vec con =3D + List.iter (fun (entry, value) -> + let path =3D (if dir <> "" then dir ^ "/" ^ entry else entry) in + validate_path path; + write tid path value con) vec + +let mkdir tid path con =3D + validate_path path; + ack (sync (Queueop.mkdir tid path) con) + +let rm tid path con =3D + validate_path path; + try + ack (sync (Queueop.rm tid path) con) + with + Xb.Noent -> () + +let setperms tid path perms con =3D + validate_path path; + ack (sync (Queueop.setperms tid path (string_of_perms perms)) con) + +let setpermsv tid dir vec perms con =3D + List.iter (fun entry -> + let path =3D (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.ml= i 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 publis= hed + * 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 =3D { 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 =3D PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR +type perms =3D 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 publis= hed + * 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 =3D +{ + 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 =3D { + directory =3D (fun path -> Xsraw.directory tid path xsh); + read =3D (fun path -> Xsraw.read tid path xsh); + readv =3D (fun dir vec -> Xsraw.readv tid dir vec xsh); + write =3D (fun path value -> Xsraw.write tid path value xsh); + writev =3D (fun dir vec -> Xsraw.writev tid dir vec xsh); + mkdir =3D (fun path -> Xsraw.mkdir tid path xsh); + rm =3D (fun path -> Xsraw.rm tid path xsh); + getperms =3D (fun path -> Xsraw.getperms tid path xsh); + setperms =3D (fun path perms -> Xsraw.setperms tid path perms xsh); + setpermsv =3D (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms x= sh); +} + +let transaction xsh (f: ops -> 'a) : 'a =3D + let commited =3D ref false and result =3D ref None in + while not !commited + do + let tid =3D Xsraw.transaction_start xsh in + let t =3D get_operations tid xsh in + + begin try + result :=3D Some (f t) + with exn -> + ignore (Xsraw.transaction_end tid false xsh); + raise exn + end; + commited :=3D 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 publis= hed + * 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 =3D { + 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 --------------1.7.0.4 Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline _______________________________________________ Xen-devel mailing list Xen-devel@lists.xensource.com http://lists.xensource.com/xen-devel --------------1.7.0.4--