@@ -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
@@ -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
new file mode 100644
@@ -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"
new file mode 100644
@@ -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
new file mode 100644
@@ -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"
new file mode 100644
@@ -0,0 +1,38 @@
+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
+
new file mode 100644
@@ -0,0 +1,162 @@
+/* SPDX-License-Identifier: LGPL-2.1-only WITH OCaml-LGPL-linking-exception */
+
+#define _GNU_SOURCE
+
+#include <stdlib.h>
+#include <string.h>
+#include <errno.h>
+
+#define CAML_NAME_SPACE
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+#include <caml/custom.h>
+
+#include <xen-tools/common-macros.h>
+#include <xenctrl.h>
+
+#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 xsd_glue_failwith(xc_interface *xch,
+ const char *func,
+ unsigned int line)
+{
+ const xc_error *error = xch ? xc_get_last_error(xch) : NULL;
+ char *str = NULL;
+ CAMLparam0();
+ CAMLlocal1(msg);
+
+#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);
+}
new file mode 100644
@@ -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__
new file mode 100644
@@ -0,0 +1 @@
+(* SPDX-License-Identifier: LGPL-2.1-only WITH OCaml-LGPL-linking-exception *)
new file mode 100644
@@ -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"
new file mode 100644
@@ -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)