diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile index 1557fd6c3c..7252eb23d7 100644 --- a/tools/ocaml/Makefile +++ b/tools/ocaml/Makefile @@ -29,6 +29,7 @@ build-tools-oxenstored: $(MAKE) -s -C libs/mmap $(MAKE) -s -C libs/xb $(MAKE) -s -C libs/xc + $(MAKE) -s -C libs/xsd_glue $(MAKE) -C xenstored .PHONY: format diff --git a/tools/ocaml/libs/Makefile b/tools/ocaml/libs/Makefile index 89350aa12f..6bcec58502 100644 --- a/tools/ocaml/libs/Makefile +++ b/tools/ocaml/libs/Makefile @@ -4,7 +4,7 @@ include $(XEN_ROOT)/tools/Rules.mk SUBDIRS= \ mmap \ eventchn xc \ - xb xs + xb xs xsd_glue .PHONY: all all: subdirs-all diff --git a/tools/ocaml/libs/xsd_glue/META.in b/tools/ocaml/libs/xsd_glue/META.in new file mode 100644 index 0000000000..dbd584ac17 --- /dev/null +++ b/tools/ocaml/libs/xsd_glue/META.in @@ -0,0 +1,4 @@ +version = "@VERSION@" +description = "A small library on top of unstable Xenctrl interfaces used by Oxenstored" +archive(byte) = "plugin_interface_v1.cma" +archive(native) = "plugin_interface_v1.cmxa" diff --git a/tools/ocaml/libs/xsd_glue/Makefile b/tools/ocaml/libs/xsd_glue/Makefile new file mode 100644 index 0000000000..f84291f7fe --- /dev/null +++ b/tools/ocaml/libs/xsd_glue/Makefile @@ -0,0 +1,46 @@ +OCAML_TOPLEVEL=$(CURDIR)/../.. +XEN_ROOT=$(OCAML_TOPLEVEL)/../.. +include $(OCAML_TOPLEVEL)/common.make + +SUBDIRS= domain_getinfo_plugin_v1 + +CFLAGS += $(CFLAGS_xeninclude) +OCAMLOPTFLAGS += -opaque + +OBJS = plugin_interface_v1 +INTF = $(foreach obj, $(OBJS),$(obj).cmi) +LIBS = plugin_interface_v1.cma plugin_interface_v1.cmxa +LIBS_plugin_interface_v1 = +plugin_interface_v1_OBJS=$(OBJS) + +.PHONY: all +all: $(INTF) $(LIBS) $(PROGRAMS) subdirs-all + +bins: $(PROGRAMS) + +libs: $(LIBS) + +plugin_interface_v1 = $(OBJS) + +OCAML_NOC_LIBRARY = plugin_interface_v1 + +.PHONY: install +install: $(LIBS) META subdirs-install + mkdir -p $(OCAMLDESTDIR) + $(OCAMLFIND) remove -destdir $(OCAMLDESTDIR) xsd_glue + $(OCAMLFIND) install -destdir $(OCAMLDESTDIR) -ldconf ignore xsd_glue META $(INTF) $(LIBS) + $(OCAMLFIND) remove -destdir $(OCAMLDESTDIR) xsd_glue_dev + $(OCAMLFIND) install -destdir $(OCAMLDESTDIR) -ldconf ignore xsd_glue_dev META $(INTF) $(LIBS) *.ml *.mli + +.PHONY: uninstall +uninstall: subdirs-uninstall + $(OCAMLFIND) remove -destdir $(OCAMLDESTDIR) xsd_glue + $(OCAMLFIND) remove -destdir $(OCAMLDESTDIR) xsd_glue_dev + +.PHONY: clean +clean: subdirs-clean + +.PHONY: distclean +distclean: subdirs-distclean + +include $(OCAML_TOPLEVEL)/Makefile.rules diff --git a/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/META.in b/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/META.in new file mode 100644 index 0000000000..fb917def62 --- /dev/null +++ b/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/META.in @@ -0,0 +1,5 @@ +version = "@VERSION@" +description = "Xenstored plugin for Xenctrl.domain_getinfo unstable interface - V1" +requires = "plugin_interface_v1" +archive(byte) = "domain_getinfo_v1.cma" +archive(native) = "domain_getinfo_v1.cmxa" diff --git a/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/Makefile b/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/Makefile new file mode 100644 index 0000000000..4be1feacfe --- /dev/null +++ b/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/Makefile @@ -0,0 +1,37 @@ +OCAML_TOPLEVEL=$(CURDIR)/../../.. +XEN_ROOT=$(OCAML_TOPLEVEL)/../.. +include $(OCAML_TOPLEVEL)/common.make + +CFLAGS += -I $(OCAML_TOPLEVEL)/libs -I $(OCAML_TOPLEVEL)/libs/xsd_glue +CFLAGS += $(CFLAGS_libxenctrl) $(CFLAGS_xeninclude) $(APPEND_CFLAGS) +OCAMLOPTFLAGS += -opaque +OCAMLINCLUDE += -I ./ -I ../ + +OBJS = domain_getinfo_v1 +INTF = $(foreach obj, $(OBJS),$(obj).cmi) +LIBS = domain_getinfo_v1.cmxa domain_getinfo_v1.cmxs + +LIBS_xsd_glue = $(call xenlibs-ldflags-ldlibs,xenctrl) + +all: $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +domain_getinfo_v1_OBJS = $(OBJS) +domain_getinfo_v1 = $(OBJS) +domain_getinfo_v1_C_OBJS = domain_getinfo_stubs_v1 + +OCAML_DYN_LIBRARY = domain_getinfo_v1 + +.PHONY: install +install: $(LIBS) META + $(INSTALL_DIR) $(DESTDIR)$(LIBEXEC)/ocaml/xsd_glue/xenctrl_plugin + $(INSTALL_PROG) domain_getinfo_v1.cmxs $(DESTDIR)$(LIBEXEC)/ocaml/xsd_glue/xenctrl_plugin + +.PHONY: uninstall +uninstall: + rm -f $(DESTDIR)$(LIBEXEC)/ocaml/xsd_glue/xenctrl_plugin/domain_getinfo_v1.cmxs + +include $(OCAML_TOPLEVEL)/Makefile.rules diff --git a/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/domain_getinfo_stubs_v1.c b/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/domain_getinfo_stubs_v1.c new file mode 100644 index 0000000000..7be386f4d4 --- /dev/null +++ b/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/domain_getinfo_stubs_v1.c @@ -0,0 +1,160 @@ +/* SPDX-License-Identifier: LGPL-2.1-only WITH OCaml-LGPL-linking-exception */ + +#define _GNU_SOURCE +#include +#include +#include + +#define CAML_NAME_SPACE +#include +#include +#include +#include +#include +#include + +#include +#include + +#include "xen-caml-compat.h" + +static inline xc_interface *xsd_glue_xch_of_val(value v) +{ + xc_interface *xch = *(xc_interface **)Data_custom_val(v); + + return xch; +} + +static void xsd_glue_xenctrl_finalize(value v) +{ + xc_interface *xch = xsd_glue_xch_of_val(v); + + xc_interface_close(xch); +} + +static struct custom_operations xsd_glue_xenctrl_ops = { + .identifier = "xsd_glue.domain_getinfo_v1.xenctrl", + .finalize = xsd_glue_xenctrl_finalize, + .compare = custom_compare_default, /* Can't compare */ + .hash = custom_hash_default, /* Can't hash */ + .serialize = custom_serialize_default, /* Can't serialize */ + .deserialize = custom_deserialize_default, /* Can't deserialize */ + .compare_ext = custom_compare_ext_default, /* Can't compare */ +}; + +static void Noreturn xsd_glue_failwith( + xc_interface *xch, const char *func, unsigned int line) +{ + CAMLparam0(); + CAMLlocal1(msg); + const xc_error *error = xch ? xc_get_last_error(xch) : NULL; + char *str = NULL; + +#define ERR (error && error->code != XC_ERROR_NONE) + + int ret = asprintf(&str, + "%d: %s%s%s - called from %s:%u", + ERR ? error->code : errno, + ERR ? xc_error_code_to_desc(error->code) : strerror(errno), + ERR ? ": " : "", + ERR ? error->message : "", + func, line); + +#undef ERR + + if (!*str || (ret == -1)) + caml_raise_out_of_memory(); + + msg = caml_copy_string(str); + free(str); + + caml_raise_with_arg(*caml_named_value("xsg.error_v1"), msg); +} +#define xsd_glue_failwith(xch) xsd_glue_failwith(xch, __func__, __LINE__) + +CAMLprim value stub_xsd_glue_xc_interface_open(value unit) +{ + CAMLparam1(unit); + CAMLlocal1(result); + xc_interface *xch; + + result = caml_alloc_custom(&xsd_glue_xenctrl_ops, sizeof(xch), 0, 1); + + caml_enter_blocking_section(); + xch = xc_interface_open(NULL, NULL, 0); + caml_leave_blocking_section(); + + if (!xch) + xsd_glue_failwith(xch); + + *(xc_interface **)Data_custom_val(result) = xch; + + CAMLreturn(result); +} + +static value xsd_glue_alloc_domaininfo(const xc_domaininfo_t *info) +{ + CAMLparam0(); + CAMLlocal1(result); + + result = caml_alloc_tuple(4); + + Store_field(result, 0, Val_int(info->domain)); + Store_field(result, 1, Val_bool(info->flags & XEN_DOMINF_dying)); + Store_field(result, 2, Val_bool(info->flags & XEN_DOMINF_shutdown)); + Store_field(result, 3, Val_int(MASK_EXTR(info->flags, XEN_DOMINF_shutdownmask))); + + CAMLreturn(result); +} + +CAMLprim value stub_xsd_glue_xc_domain_getinfo(value xch_val, value domid) +{ + CAMLparam2(xch_val, domid); + CAMLlocal1(result); + xc_interface *xch = xsd_glue_xch_of_val(xch_val); + xc_domaininfo_t info; + int ret; + int domid_c = Int_val(domid); + + caml_enter_blocking_section(); + ret = xc_domain_getinfo_single(xch, domid_c, &info); + caml_leave_blocking_section(); + + if (ret < 0) + xsd_glue_failwith(xch); + + result = xsd_glue_alloc_domaininfo(&info); + + CAMLreturn(result); +} + +CAMLprim value stub_xsd_glue_xc_domain_getinfolist(value xch_val) +{ + CAMLparam1(xch_val); + CAMLlocal1(result); + xc_interface *xch = xsd_glue_xch_of_val(xch_val); + xc_domaininfo_t *info; + int i, retval; + + /* get the minimum number of allocate byte we need and bump it up to page boundary */ + info = malloc(sizeof(xc_domaininfo_t) * DOMID_FIRST_RESERVED); + if (!info) + caml_raise_out_of_memory(); + + caml_enter_blocking_section(); + retval = xc_domain_getinfolist(xch, 0, DOMID_FIRST_RESERVED, info); + caml_leave_blocking_section(); + + if (retval <= 0) { + free(info); + xsd_glue_failwith(xch); + } + + result = caml_alloc(retval, 0); + for (i = 0; i < retval; i++) { + caml_modify(&Field(result, i), xsd_glue_alloc_domaininfo(info + i)); + } + + free(info); + CAMLreturn(result); +} diff --git a/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/domain_getinfo_v1.ml b/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/domain_getinfo_v1.ml new file mode 100644 index 0000000000..be50853c4b --- /dev/null +++ b/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/domain_getinfo_v1.ml @@ -0,0 +1,35 @@ +(* SPDX-License-Identifier: LGPL-2.1-only WITH OCaml-LGPL-linking-exception *) +(** Minimal interface on top of unstable Xenctrl for Oxenstored's usage *) + +module P = Plugin_interface_v1 + +module M : P.Domain_getinfo_V1 = struct + exception Error of string + + type domid = int + type handle + + type domaininfo = { + domid : domid; + dying : bool; + shutdown : bool; + shutdown_code : int; + } + + external interface_open : unit -> handle = "stub_xsd_glue_xc_interface_open" + + external domain_getinfo : handle -> domid -> domaininfo + = "stub_xsd_glue_xc_domain_getinfo" + + external domain_getinfolist : handle -> domaininfo array + = "stub_xsd_glue_xc_domain_getinfolist" + + let _ = Callback.register_exception "xsg.error_v1" (Error "register_callback") +end + +let () = + Printf.ksprintf !P.logging_function "Registration of %s plugin started\n%!" + __MODULE__; + P.register_plugin_v1 (module M : P.Domain_getinfo_V1); + Printf.ksprintf !P.logging_function "Registration of %s plugin successful\n%!" + __MODULE__ diff --git a/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/domain_getinfo_v1.mli b/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/domain_getinfo_v1.mli new file mode 100644 index 0000000000..465beda1a3 --- /dev/null +++ b/tools/ocaml/libs/xsd_glue/domain_getinfo_plugin_v1/domain_getinfo_v1.mli @@ -0,0 +1 @@ +(* SPDX-License-Identifier: LGPL-2.1-only WITH OCaml-LGPL-linking-exception *) diff --git a/tools/ocaml/libs/xsd_glue/plugin_interface_v1.ml b/tools/ocaml/libs/xsd_glue/plugin_interface_v1.ml new file mode 100644 index 0000000000..5ab98b83bd --- /dev/null +++ b/tools/ocaml/libs/xsd_glue/plugin_interface_v1.ml @@ -0,0 +1,30 @@ +(* SPDX-License-Identifier: LGPL-2.1-only WITH OCaml-LGPL-linking-exception *) + +module type Domain_getinfo_V1 = sig + exception Error of string + + type domid = int + type handle + + type domaininfo = { + domid : domid; + dying : bool; + shutdown : bool; + shutdown_code : int; + } + + val interface_open : unit -> handle + val domain_getinfo : handle -> domid -> domaininfo + val domain_getinfolist : handle -> domaininfo array +end + +let ignore_logging : string -> unit = ignore +let logging_function = ref ignore_logging +let register_logging_function func = logging_function := func +let plugin_implementation_v1 : (module Domain_getinfo_V1) option ref = ref None +let register_plugin_v1 m = plugin_implementation_v1 := Some m + +let get_plugin_v1 () : (module Domain_getinfo_V1) = + match !plugin_implementation_v1 with + | Some s -> s + | None -> failwith "No plugin loaded" diff --git a/tools/ocaml/libs/xsd_glue/plugin_interface_v1.mli b/tools/ocaml/libs/xsd_glue/plugin_interface_v1.mli new file mode 100644 index 0000000000..69f91510f7 --- /dev/null +++ b/tools/ocaml/libs/xsd_glue/plugin_interface_v1.mli @@ -0,0 +1,38 @@ +(* SPDX-License-Identifier: LGPL-2.1-only WITH OCaml-LGPL-linking-exception *) + +(** To avoid breaking the plugin interface, this module needs to be + standalone and can't rely on any other Xen library. Even unrelated + changes in the interfaces of those modules would change the hash + of this interface and break the plugin system. + It can only depend on Stdlib, therefore all of the types (domid, + domaininfo etc.) are redefined here instead of using alternatives + defined elsewhere. + + NOTE: The signature of this interface should not be changed (no + functions or types can be added, modified, or removed). If + underlying Xenctrl changes require a new interface, a V2 with a + corresponding plugin should be created. +*) + +module type Domain_getinfo_V1 = sig + exception Error of string + + type domid = int + type handle + + type domaininfo = { + domid : domid; + dying : bool; + shutdown : bool; + shutdown_code : int; + } + + val interface_open : unit -> handle + val domain_getinfo : handle -> domid -> domaininfo + val domain_getinfolist : handle -> domaininfo array +end + +val register_logging_function : (string -> unit) -> unit +val logging_function : (string -> unit) ref +val register_plugin_v1 : (module Domain_getinfo_V1) -> unit +val get_plugin_v1 : unit -> (module Domain_getinfo_V1)