Pino Toscano
2018-Nov-27 10:59 UTC
[Libguestfs] [PATCH v2 0/7] RFC: switch v2v to ocaml-libvirt
Hi, this is a mostly done attempt to switch to ocaml-libvirt, embedding the latest version of it from git. This way, it is possible to improve the way v2v connects to libvirt for both input, and output modules, and interacts with libvirt (e.g. no more virsh calls needed in virt-v2v). As side effect, virt-v2v now requires libvirt, as keeping it optional would create too much burden. I could not test all the libvirt input modes (like VDDK, and Xen), but VMware and libvirtxml work fine as before. Changes from v1: - rebase on master - update ocaml-libvirt from libvirt-ocaml.git on libvirt.org, and adjust the code to it - pass again the URI to input_libvirt_vddk, so an error message is preserved Pino Toscano (7): v2v: require libvirt common: Bundle the libvirt-ocaml library for use by virt-v2v v2v: switch to ocaml-libvirt v2v: -o libvirt: use a Lazy for the connection v2v: -o libvirt: switch away from virsh v2v: test-harness: stop using the external ocaml-libvirt build: stop looking for ocaml-libvirt .gitignore | 2 + Makefile.am | 5 +- common/mllibvirt/Makefile.am | 102 ++ common/mllibvirt/generator.pl | 908 +++++++++++++ common/mllibvirt/libvirt.README | 9 + common/mllibvirt/libvirt.ml | 1661 ++++++++++++++++++++++++ common/mllibvirt/libvirt.mli | 1626 +++++++++++++++++++++++ common/mllibvirt/libvirt_c_epilogue.c | 462 +++++++ common/mllibvirt/libvirt_c_oneoffs.c | 1698 +++++++++++++++++++++++++ common/mllibvirt/libvirt_c_prologue.c | 134 ++ configure.ac | 1 + docs/C_SOURCE_FILES | 1 - m4/guestfs-ocaml.m4 | 4 - po/POTFILES | 1 - v2v/Makefile.am | 26 +- v2v/copy_to_local.ml | 7 +- v2v/dummy.c | 2 + v2v/input_libvirt.ml | 20 +- v2v/input_libvirt_other.ml | 27 +- v2v/input_libvirt_other.mli | 5 +- v2v/input_libvirt_vcenter_https.ml | 13 +- v2v/input_libvirt_vcenter_https.mli | 2 +- v2v/input_libvirt_vddk.ml | 15 +- v2v/input_libvirt_vddk.mli | 4 +- v2v/input_libvirt_xen_ssh.ml | 13 +- v2v/input_libvirt_xen_ssh.mli | 2 +- v2v/input_libvirtxml.ml | 3 +- v2v/libvirt_utils-c.c | 539 -------- v2v/libvirt_utils.ml | 95 +- v2v/libvirt_utils.mli | 51 +- v2v/output_libvirt.ml | 56 +- v2v/parse_libvirt_xml.ml | 14 +- v2v/parse_libvirt_xml.mli | 11 +- v2v/test-harness/Makefile.am | 5 +- v2v/v2v.ml | 12 +- 35 files changed, 6838 insertions(+), 698 deletions(-) create mode 100644 common/mllibvirt/Makefile.am create mode 100755 common/mllibvirt/generator.pl create mode 100644 common/mllibvirt/libvirt.README create mode 100644 common/mllibvirt/libvirt.ml create mode 100644 common/mllibvirt/libvirt.mli create mode 100644 common/mllibvirt/libvirt_c_epilogue.c create mode 100644 common/mllibvirt/libvirt_c_oneoffs.c create mode 100644 common/mllibvirt/libvirt_c_prologue.c create mode 100644 v2v/dummy.c delete mode 100644 v2v/libvirt_utils-c.c -- 2.17.2
While there are input modes that do not use libvirt, making libvirt
mandatory for virt-v2v slightly simplifies the code now, and allow for
further improvements/integration with libvirt later on.
---
Makefile.am | 2 ++
v2v/Makefile.am | 20 ++++++--------------
v2v/libvirt_utils-c.c | 22 ----------------------
v2v/v2v.ml | 12 +++---------
4 files changed, 11 insertions(+), 45 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 5d1d7b53d..c8436286c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -169,10 +169,12 @@ SUBDIRS += get-kernel
SUBDIRS += resize
SUBDIRS += sparsify
SUBDIRS += sysprep
+if HAVE_LIBVIRT
SUBDIRS += v2v
if HAVE_OCAML_PKG_LIBVIRT
SUBDIRS += v2v/test-harness
endif
+endif
if HAVE_FUSE
SUBDIRS += dib
endif
diff --git a/v2v/Makefile.am b/v2v/Makefile.am
index d8a7487f3..97ae6d0c6 100644
--- a/v2v/Makefile.am
+++ b/v2v/Makefile.am
@@ -414,6 +414,7 @@ stamp-virt-v2v-support.pod: virt-v2v-support.pod
TESTS_ENVIRONMENT = $(top_builddir)/run --test
TESTS = \
+ test-v2v-copy-to-local.sh \
test-v2v-docs.sh \
test-v2v-python-syntax.sh \
test-v2v-i-ova-bad-sha1.sh \
@@ -433,29 +434,19 @@ TESTS = \
test-v2v-o-vdsm-oo-query.sh \
test-v2v-bad-networks-and-bridges.sh
-if HAVE_LIBVIRT
-TESTS += \
- test-v2v-copy-to-local.sh
-endif
-
if HAVE_OCAML_PKG_OUNIT
TESTS += v2v_unit_tests
endif
if ENABLE_APPLIANCE
-TESTS += \
- test-v2v-i-ova.sh \
- test-v2v-i-disk.sh \
- test-v2v-machine-readable.sh \
- test-v2v-virtio-win-iso.sh \
- test-v2v-windows-conversion.sh
-
-if HAVE_LIBVIRT
TESTS += \
test-v2v-cdrom.sh \
test-v2v-floppy.sh \
+ test-v2v-i-disk.sh \
+ test-v2v-i-ova.sh \
test-v2v-in-place.sh \
test-v2v-mac.sh \
+ test-v2v-machine-readable.sh \
test-v2v-networks-and-bridges.sh \
test-v2v-no-copy.sh \
test-v2v-o-glance.sh \
@@ -472,9 +463,10 @@ TESTS += \
test-v2v-print-estimate.sh \
test-v2v-print-source.sh \
test-v2v-sound.sh \
+ test-v2v-virtio-win-iso.sh \
+ test-v2v-windows-conversion.sh
$(SLOW_TESTS) \
$(ROOT_TESTS)
-endif
endif ENABLE_APPLIANCE
# The VMDK file is used for some -i ova tests.
diff --git a/v2v/libvirt_utils-c.c b/v2v/libvirt_utils-c.c
index 4f29fc6e9..e966c0117 100644
--- a/v2v/libvirt_utils-c.c
+++ b/v2v/libvirt_utils-c.c
@@ -35,18 +35,14 @@
#include <caml/memory.h>
#include <caml/mlvalues.h>
-#ifdef HAVE_LIBVIRT
#include <libvirt/libvirt.h>
#include <libvirt/virterror.h>
-#endif
#include "guestfs.h"
#include "guestfs-utils.h"
#pragma GCC diagnostic ignored "-Wmissing-prototypes"
-#ifdef HAVE_LIBVIRT
-
#define ERROR_MESSAGE_LEN 512
static void
@@ -519,21 +515,3 @@ v2v_libvirt_get_version (value unitv)
CAMLreturn (rv);
}
-
-#else /* !HAVE_LIBVIRT */
-
-#define NO_LIBVIRT(proto) \
- proto __attribute__((noreturn)); \
- proto \
- { \
- caml_invalid_argument ("virt-v2v was compiled without libvirt
support"); \
- }
-
-NO_LIBVIRT (value v2v_dumpxml (value connv, value domv))
-NO_LIBVIRT (value v2v_pool_dumpxml (value connv, value poolv))
-NO_LIBVIRT (value v2v_vol_dumpxml (value connv, value poolnamev, value
volnamev))
-NO_LIBVIRT (value v2v_capabilities (value connv, value unitv))
-NO_LIBVIRT (value v2v_domain_exists (value connv, value domnamev))
-NO_LIBVIRT (value v2v_libvirt_get_version (value unitv))
-
-#endif /* !HAVE_LIBVIRT */
diff --git a/v2v/v2v.ml b/v2v/v2v.ml
index 372068e12..b862c840b 100644
--- a/v2v/v2v.ml
+++ b/v2v/v2v.ml
@@ -59,16 +59,10 @@ let rec main () prog Guestfs_config.package_name
Guestfs_config.package_version_full
Guestfs_config.host_cpu;
- (* Print the libvirt version if debugging. Note that if
- * we're configured --without-libvirt, then this will throw
- * an exception, but some conversions should still be possible,
- * hence the try block.
- *)
+ (* Print the libvirt version if debugging. *)
if verbose () then (
- try
- let major, minor, release = Libvirt_utils.libvirt_get_version () in
- debug "libvirt version: %d.%d.%d" major minor release
- with _ -> ()
+ let major, minor, release = Libvirt_utils.libvirt_get_version () in
+ debug "libvirt version: %d.%d.%d" major minor release
);
(* Perform pre-flight checks on the input and output objects. *)
--
2.17.2
Pino Toscano
2018-Nov-27 10:59 UTC
[Libguestfs] [PATCH v2 2/7] common: Bundle the libvirt-ocaml library for use by virt-v2v
Add a copy of the libvirt-ocaml library, currently available at:
https://libvirt.org/git/?p=libvirt-ocaml.git;a=summary
This is a snapshot at commit 8893bf9b7dd31594943ec8a88ce63133fa7f4a72,
which has all the features we need (and that builds fine).
It is expected to stay synchronized with upstream, until there is a new
upstream release, and it will be widespread enough.
---
.gitignore | 2 +
Makefile.am | 3 +
common/mllibvirt/Makefile.am | 102 ++
common/mllibvirt/generator.pl | 908 +++++++++++++
common/mllibvirt/libvirt.README | 9 +
common/mllibvirt/libvirt.ml | 1661 ++++++++++++++++++++++++
common/mllibvirt/libvirt.mli | 1626 +++++++++++++++++++++++
common/mllibvirt/libvirt_c_epilogue.c | 462 +++++++
common/mllibvirt/libvirt_c_oneoffs.c | 1698 +++++++++++++++++++++++++
common/mllibvirt/libvirt_c_prologue.c | 134 ++
configure.ac | 1 +
11 files changed, 6606 insertions(+)
create mode 100644 common/mllibvirt/Makefile.am
create mode 100755 common/mllibvirt/generator.pl
create mode 100644 common/mllibvirt/libvirt.README
create mode 100644 common/mllibvirt/libvirt.ml
create mode 100644 common/mllibvirt/libvirt.mli
create mode 100644 common/mllibvirt/libvirt_c_epilogue.c
create mode 100644 common/mllibvirt/libvirt_c_oneoffs.c
create mode 100644 common/mllibvirt/libvirt_c_prologue.c
diff --git a/.gitignore b/.gitignore
index fe5aa6d70..cb396979a 100644
--- a/.gitignore
+++ b/.gitignore
@@ -133,6 +133,8 @@ Makefile.in
/common/mlaugeas/.depend
/common/mlgettext/.depend
/common/mlgettext/common_gettext.ml
+/common/mllibvirt/.depend
+/common/mllibvirt/libvirt_c.c
/common/mlpcre/.depend
/common/mlpcre/pcre_tests
/common/mlprogress/.depend
diff --git a/Makefile.am b/Makefile.am
index c8436286c..4882894a8 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -163,6 +163,9 @@ SUBDIRS += common/mlprogress
SUBDIRS += common/mlvisit
SUBDIRS += common/mlxml
SUBDIRS += common/mltools
+if HAVE_LIBVIRT
+SUBDIRS += common/mllibvirt
+endif
SUBDIRS += customize
SUBDIRS += builder builder/templates
SUBDIRS += get-kernel
diff --git a/common/mllibvirt/Makefile.am b/common/mllibvirt/Makefile.am
new file mode 100644
index 000000000..1739303b7
--- /dev/null
+++ b/common/mllibvirt/Makefile.am
@@ -0,0 +1,102 @@
+# libguestfs OCaml tools common code
+# Copyright (C) 2018 Red Hat Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# 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 General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+include $(top_srcdir)/subdir-rules.mk
+
+EXTRA_DIST = \
+ $(SOURCES_MLI) \
+ $(SOURCES_ML) \
+ generator.pl \
+ libvirt_c_epilogue.c \
+ libvirt_c_oneoffs.c \
+ libvirt_c_prologue.c \
+ libvirt.README
+
+SOURCES_MLI = \
+ libvirt.mli
+
+SOURCES_ML = \
+ libvirt.ml
+
+SOURCES_C = \
+ libvirt_c.c
+
+# Automatically generate the C code from a Perl script 'generator.pl'.
+libvirt_c.c: generator.pl
+ $(PERL) -w $<
+
+CLEANFILES += \
+ libvirt_c.c
+
+# We pretend that we're building a C library. automake handles the
+# compilation of the C sources for us. At the end we take the C
+# objects and OCaml objects and link them into the OCaml library.
+# This C library is never used.
+
+noinst_LIBRARIES = libmllibvirt.a
+
+if !HAVE_OCAMLOPT
+MLLIBVIRT_CMA = mllibvirt.cma
+else
+MLLIBVIRT_CMA = mllibvirt.cmxa
+endif
+
+noinst_DATA = $(MLLIBVIRT_CMA)
+
+libmllibvirt_a_SOURCES = $(SOURCES_C)
+libmllibvirt_a_CPPFLAGS = \
+ -I. \
+ -I$(top_builddir) \
+ -I$(shell $(OCAMLC) -where)
+libmllibvirt_a_CFLAGS = \
+ $(WARN_CFLAGS) $(WERROR_CFLAGS) \
+ $(LIBVIRT_CFLAGS) \
+ -fPIC
+
+BOBJECTS = $(SOURCES_ML:.ml=.cmo)
+XOBJECTS = $(BOBJECTS:.cmo=.cmx)
+
+OCAMLPACKAGES +OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR)
+
+if !HAVE_OCAMLOPT
+OBJECTS = $(BOBJECTS)
+else
+OBJECTS = $(XOBJECTS)
+endif
+
+libmllibvirt_a_DEPENDENCIES = $(OBJECTS)
+
+$(MLLIBVIRT_CMA): $(OBJECTS) libmllibvirt.a
+ $(OCAMLFIND) mklib $(OCAMLPACKAGES) \
+ $(OBJECTS) $(libmllibvirt_a_OBJECTS) -cclib -lvirt -o mllibvirt
+
+# Dependencies.
+depend: .depend
+
+.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml)
+ rm -f $@ $@-t
+ $(OCAMLFIND) ocamldep -I ../../ocaml -I $(abs_srcdir) $^ | \
+ $(SED) 's/ *$$//' | \
+ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \
+ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \
+ sort > $@-t
+ mv $@-t $@
+
+-include .depend
+
+.PHONY: depend docs
diff --git a/common/mllibvirt/generator.pl b/common/mllibvirt/generator.pl
new file mode 100755
index 000000000..490ef9add
--- /dev/null
+++ b/common/mllibvirt/generator.pl
@@ -0,0 +1,908 @@
+#!/usr/bin/perl -w
+#
+# OCaml bindings for libvirt.
+# (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc.
+# https://libvirt.org/
+#
+# This library 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; either
+# version 2 of the License, or (at your option) any later version,
+# with the OCaml linking exception described in ../COPYING.LIB.
+#
+# This library 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.
+#
+# You should have received a copy of the GNU Lesser General Public
+# License along with this library; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+# This generates libvirt_c.c (the core of the bindings). You don't
+# need to run this program unless you are extending the bindings
+# themselves (eg. because libvirt has been extended).
+#
+# Please read libvirt/README.
+
+use strict;
+
+#----------------------------------------------------------------------
+
+# The functions in the libvirt API that we can generate.
+
+# The 'sig' (signature) doesn't have a meaning or any internal
structure.
+# It is interpreted by the generation functions below to indicate what
+# "class" the function falls into, and to generate the right class of
+# binding.
+
+my @functions = (
+ { name => "virConnectClose", sig => "conn : free"
},
+ { name => "virConnectGetHostname", sig => "conn :
string" },
+ { name => "virConnectGetURI", sig => "conn :
string" },
+ { name => "virConnectGetType", sig => "conn : static
string" },
+ { name => "virConnectNumOfDomains", sig => "conn :
int" },
+ { name => "virConnectListDomains", sig => "conn, int :
int array" },
+ { name => "virConnectNumOfDefinedDomains", sig =>
"conn : int" },
+ { name => "virConnectListDefinedDomains",
+ sig => "conn, int : string array" },
+ { name => "virConnectNumOfNetworks", sig => "conn :
int" },
+ { name => "virConnectListNetworks", sig => "conn, int
: string array" },
+ { name => "virConnectNumOfDefinedNetworks", sig =>
"conn : int" },
+ { name => "virConnectListDefinedNetworks",
+ sig => "conn, int : string array" },
+ { name => "virConnectNumOfStoragePools", sig => "conn
: int" },
+ { name => "virConnectListStoragePools",
+ sig => "conn, int : string array" },
+ { name => "virConnectNumOfDefinedStoragePools",
+ sig => "conn : int" },
+ { name => "virConnectListDefinedStoragePools",
+ sig => "conn, int : string array" },
+ { name => "virConnectNumOfSecrets", sig => "conn :
int" },
+ { name => "virConnectListSecrets", sig => "conn, int :
string array" },
+ { name => "virConnectGetCapabilities", sig => "conn :
string" },
+ { name => "virConnectDomainEventDeregisterAny",
+ sig => "conn, int : unit" },
+
+ { name => "virDomainCreateLinux", sig => "conn,
string, 0U : dom" },
+ { name => "virDomainCreateXML", sig => "conn, string,
unsigned : dom" },
+ { name => "virDomainFree", sig => "dom : free" },
+ { name => "virDomainDestroy", sig => "dom : free"
},
+ { name => "virDomainLookupByName", sig => "conn,
string : dom" },
+ { name => "virDomainLookupByID", sig => "conn, int :
dom" },
+ { name => "virDomainLookupByUUID", sig => "conn, uuid
: dom" },
+ { name => "virDomainLookupByUUIDString", sig => "conn,
string : dom" },
+ { name => "virDomainGetName", sig => "dom : static
string" },
+ { name => "virDomainGetOSType", sig => "dom :
string" },
+ { name => "virDomainGetXMLDesc", sig => "dom, 0 :
string" },
+ { name => "virDomainGetUUID", sig => "dom : uuid"
},
+ { name => "virDomainGetUUIDString", sig => "dom : uuid
string" },
+ { name => "virDomainGetMaxVcpus", sig => "dom :
int" },
+ { name => "virDomainSave", sig => "dom, string :
unit" },
+ { name => "virDomainRestore", sig => "conn, string :
unit" },
+ { name => "virDomainCoreDump", sig => "dom, string, 0
: unit" },
+ { name => "virDomainSuspend", sig => "dom : unit"
},
+ { name => "virDomainResume", sig => "dom : unit"
},
+ { name => "virDomainShutdown", sig => "dom :
unit" },
+ { name => "virDomainReboot", sig => "dom, 0 :
unit" },
+ { name => "virDomainDefineXML", sig => "conn, string :
dom" },
+ { name => "virDomainUndefine", sig => "dom :
unit" },
+ { name => "virDomainCreate", sig => "dom : unit"
},
+ { name => "virDomainAttachDevice", sig => "dom, string
: unit" },
+ { name => "virDomainDetachDevice", sig => "dom, string
: unit" },
+ { name => "virDomainGetAutostart", sig => "dom :
bool" },
+ { name => "virDomainSetAutostart", sig => "dom, bool :
unit" },
+
+ { name => "virNetworkFree", sig => "net : free"
},
+ { name => "virNetworkDestroy", sig => "net :
free" },
+ { name => "virNetworkLookupByName", sig => "conn,
string : net" },
+ { name => "virNetworkLookupByUUID", sig => "conn, uuid
: net" },
+ { name => "virNetworkLookupByUUIDString", sig =>
"conn, string : net" },
+ { name => "virNetworkGetName", sig => "net : static
string" },
+ { name => "virNetworkGetXMLDesc", sig => "net, 0 :
string" },
+ { name => "virNetworkGetBridgeName", sig => "net :
string" },
+ { name => "virNetworkGetUUID", sig => "net :
uuid" },
+ { name => "virNetworkGetUUIDString", sig => "net :
uuid string" },
+ { name => "virNetworkUndefine", sig => "net :
unit" },
+ { name => "virNetworkCreateXML", sig => "conn, string
: net" },
+ { name => "virNetworkDefineXML", sig => "conn, string
: net" },
+ { name => "virNetworkCreate", sig => "net : unit"
},
+ { name => "virNetworkGetAutostart", sig => "net :
bool" },
+ { name => "virNetworkSetAutostart", sig => "net, bool
: unit" },
+
+ { name => "virStoragePoolFree", sig => "pool :
free" },
+ { name => "virStoragePoolDestroy", sig => "pool :
free" },
+ { name => "virStoragePoolLookupByName",
+ sig => "conn, string : pool" },
+ { name => "virStoragePoolLookupByUUID",
+ sig => "conn, uuid : pool" },
+ { name => "virStoragePoolLookupByUUIDString",
+ sig => "conn, string : pool" },
+ { name => "virStoragePoolGetName",
+ sig => "pool : static string" },
+ { name => "virStoragePoolGetXMLDesc",
+ sig => "pool, 0U : string" },
+ { name => "virStoragePoolGetUUID",
+ sig => "pool : uuid" },
+ { name => "virStoragePoolGetUUIDString",
+ sig => "pool : uuid string" },
+ { name => "virStoragePoolCreateXML",
+ sig => "conn, string, 0U : pool" },
+ { name => "virStoragePoolDefineXML",
+ sig => "conn, string, 0U : pool" },
+ { name => "virStoragePoolBuild",
+ sig => "pool, uint : unit" },
+ { name => "virStoragePoolUndefine",
+ sig => "pool : unit" },
+ { name => "virStoragePoolCreate",
+ sig => "pool, 0U : unit" },
+ { name => "virStoragePoolDelete",
+ sig => "pool, uint : unit" },
+ { name => "virStoragePoolRefresh",
+ sig => "pool, 0U : unit" },
+ { name => "virStoragePoolGetAutostart",
+ sig => "pool : bool" },
+ { name => "virStoragePoolSetAutostart",
+ sig => "pool, bool : unit" },
+ { name => "virStoragePoolNumOfVolumes",
+ sig => "pool : int" },
+ { name => "virStoragePoolListVolumes",
+ sig => "pool, int : string array" },
+
+ { name => "virStorageVolFree", sig => "vol :
free" },
+ { name => "virStorageVolDelete",
+ sig => "vol, uint : unit" },
+ { name => "virStorageVolLookupByName",
+ sig => "pool, string : vol from pool" },
+ { name => "virStorageVolLookupByKey",
+ sig => "conn, string : vol" },
+ { name => "virStorageVolLookupByPath",
+ sig => "conn, string : vol" },
+ { name => "virStorageVolCreateXML",
+ sig => "pool, string, 0U : vol from pool" },
+ { name => "virStorageVolGetXMLDesc",
+ sig => "vol, 0U : string" },
+ { name => "virStorageVolGetPath",
+ sig => "vol : string" },
+ { name => "virStorageVolGetKey",
+ sig => "vol : static string" },
+ { name => "virStorageVolGetName",
+ sig => "vol : static string" },
+ { name => "virStoragePoolLookupByVolume",
+ sig => "vol : pool from vol" },
+
+ { name => "virSecretFree", sig => "sec : free" },
+ { name => "virSecretUndefine", sig => "sec :
unit" },
+ { name => "virSecretLookupByUUID", sig => "conn, uuid
: sec" },
+ { name => "virSecretLookupByUUIDString", sig => "conn,
string : sec" },
+ { name => "virSecretDefineXML", sig => "conn, string,
0 : sec" },
+ { name => "virSecretGetUUID", sig => "sec : uuid"
},
+ { name => "virSecretGetUUIDString", sig => "sec : uuid
string" },
+ { name => "virSecretGetUsageType", sig => "sec :
int" },
+ { name => "virSecretGetUsageID", sig => "sec : static
string" },
+ { name => "virSecretGetXMLDesc", sig => "sec, 0 :
string" },
+
+ );
+
+# Functions we haven't implemented anywhere yet but which are mentioned
+# in 'libvirt.ml'.
+#
+# We create stubs for these, but eventually they need to either be
+# moved ^^^ so they are auto-generated, or implementations of them
+# written in 'libvirt_c_oneoffs.c'.
+
+my @unimplemented = (
+ );
+
+#----------------------------------------------------------------------
+
+# Open the output file.
+
+my $filename = "libvirt_c.c";
+open F, ">$filename" or die "$filename: $!";
+
+# Write the prologue.
+
+print F <<'END';
+/* !!! WARNING WARNING WARNING WARNING WARNING WARNING WARNING !!!
+ *
+ * THIS FILE IS AUTOMATICALLY GENERATED BY 'generator.pl'.
+ *
+ * Any changes you make to this file may be overwritten.
+ */
+
+/* OCaml bindings for libvirt.
+ * (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc.
+ * https://libvirt.org/
+ *
+ * This library 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; either
+ * version 2 of the License, or (at your option) any later version,
+ * with the OCaml linking exception described in ../COPYING.LIB.
+ *
+ * This library 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.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+ */
+
+#include "config.h"
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <libvirt/libvirt.h>
+#include <libvirt/virterror.h>
+
+#include <caml/config.h>
+#include <caml/alloc.h>
+#include <caml/callback.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/misc.h>
+#include <caml/mlvalues.h>
+#include <caml/signals.h>
+
+#include "libvirt_c_prologue.c"
+
+#include "libvirt_c_oneoffs.c"
+
+END
+
+#----------------------------------------------------------------------
+
+sub camel_case_to_underscores
+{
+ my $name = shift;
+
+ $name =~ s/([A-Z][a-z]+|XML|URI|OS|UUID)/$1,/g;
+ my @subs = split (/,/, $name);
+ @subs = map { lc($_) } @subs;
+ join "_", @subs
+}
+
+# Helper functions dealing with signatures.
+
+sub short_name_to_c_type
+{
+ local $_ = shift;
+
+ if ($_ eq "conn") { "virConnectPtr" }
+ elsif ($_ eq "dom") { "virDomainPtr" }
+ elsif ($_ eq "net") { "virNetworkPtr" }
+ elsif ($_ eq "pool") { "virStoragePoolPtr" }
+ elsif ($_ eq "vol") { "virStorageVolPtr" }
+ elsif ($_ eq "sec") { "virSecretPtr" }
+ else {
+ die "unknown short name $_"
+ }
+}
+
+# OCaml argument names.
+
+sub gen_arg_names
+{
+ my $sig = shift;
+
+ if ($sig =~ /^(\w+) : string$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+) : static string$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+) : int$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+) : uuid$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+) : uuid string$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+) : bool$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+), bool : unit$/) {
+ ( "$1v", "bv" )
+ } elsif ($sig eq "conn, int : int array") {
+ ( "connv", "iv" )
+ } elsif ($sig =~ /^(\w+), int : string array$/) {
+ ( "$1v", "iv" )
+ } elsif ($sig =~ /^(\w+), 0U? : string$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+), 0U? : unit$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+) : unit$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+) : free$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+), string : unit$/) {
+ ( "$1v", "strv" )
+ } elsif ($sig =~ /^(\w+), string, 0U? : unit$/) {
+ ( "$1v", "strv" )
+ } elsif ($sig =~ /^(\w+), string : (\w+)$/) {
+ ( "$1v", "strv" )
+ } elsif ($sig =~ /^(\w+), string, 0U? : (\w+)$/) {
+ ( "$1v", "strv" )
+ } elsif ($sig =~ /^(\w+), string, unsigned : (\w+)$/) {
+ ( "$1v", "strv", "uv" )
+ } elsif ($sig =~ /^(\w+), u?int : (\w+)$/) {
+ ( "$1v", "iv" )
+ } elsif ($sig =~ /^(\w+), uuid : (\w+)$/) {
+ ( "$1v", "uuidv" )
+ } elsif ($sig =~ /^(\w+), 0U? : (\w+)$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+) : (\w+)$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+), string : (\w+) from \w+$/) {
+ ( "$1v", "strv" )
+ } elsif ($sig =~ /^(\w+), string, 0U? : (\w+) from \w+$/) {
+ ( "$1v", "strv" )
+ } elsif ($sig =~ /^(\w+), 0U? : (\w+) from \w+$/) {
+ ( "$1v" )
+ } elsif ($sig =~ /^(\w+) : (\w+) from \w+$/) {
+ ( "$1v" )
+ } else {
+ die "unknown signature $sig"
+ }
+}
+
+# Unpack the first (object) argument.
+
+sub gen_unpack_args
+{
+ local $_ = shift;
+
+ if ($_ eq "conn") {
+ "virConnectPtr conn = Connect_val (connv);"
+ } elsif ($_ eq "dom") {
+ "virDomainPtr dom = Domain_val (domv);"
+ } elsif ($_ eq "net") {
+ "virNetworkPtr net = Network_val (netv);"
+ } elsif ($_ eq "pool") {
+ "virStoragePoolPtr pool = Pool_val (poolv);"
+ } elsif ($_ eq "vol") {
+ "virStorageVolPtr vol = Volume_val (volv);"
+ } elsif ($_ eq "sec") {
+ "virSecretPtr sec = Secret_val (secv);"
+ } else {
+ die "unknown short name $_"
+ }
+}
+
+# Pack the result if it's an object.
+
+sub gen_pack_result
+{
+ local $_ = shift;
+
+ if ($_ eq "dom") { "rv = Val_domain (r, connv);" }
+ elsif ($_ eq "net") { "rv = Val_network (r, connv);" }
+ elsif ($_ eq "pool") { "rv = Val_pool (r, connv);" }
+ elsif ($_ eq "vol") { "rv = Val_volume (r, connv);" }
+ elsif ($_ eq "sec") { "rv = Val_secret (r, connv);" }
+ else {
+ die "unknown short name $_"
+ }
+}
+
+sub gen_free_arg
+{
+ local $_ = shift;
+
+ if ($_ eq "conn") { "Connect_val (connv) = NULL;" }
+ elsif ($_ eq "dom") { "Domain_val (domv) = NULL;" }
+ elsif ($_ eq "net") { "Network_val (netv) = NULL;" }
+ elsif ($_ eq "pool") { "Pool_val (poolv) = NULL;" }
+ elsif ($_ eq "vol") { "Volume_val (volv) = NULL;" }
+ elsif ($_ eq "sec") { "Secret_val (secv) = NULL;" }
+ else {
+ die "unknown short name $_"
+ }
+}
+
+# Generate the C body for each signature (class of function).
+
+sub gen_c_code
+{
+ my $sig = shift;
+ my $c_name = shift;
+
+ if ($sig =~ /^(\w+) : string$/) {
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ char *r;
+
+ NONBLOCKING (r = $c_name ($1));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ rv = caml_copy_string (r);
+ free (r);
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+) : static string$/) {
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ const char *r;
+
+ NONBLOCKING (r = $c_name ($1));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ rv = caml_copy_string (r);
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+) : int$/) {
+ "\
+ " . gen_unpack_args ($1) . "
+ int r;
+
+ NONBLOCKING (r = $c_name ($1));
+ CHECK_ERROR (r == -1, \"$c_name\");
+
+ CAMLreturn (Val_int (r));
+"
+ } elsif ($sig =~ /^(\w+) : uuid$/) {
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ unsigned char uuid[VIR_UUID_BUFLEN];
+ int r;
+
+ NONBLOCKING (r = $c_name ($1, uuid));
+ CHECK_ERROR (r == -1, \"$c_name\");
+
+ /* UUIDs are byte arrays with a fixed length. */
+ rv = caml_alloc_string (VIR_UUID_BUFLEN);
+ memcpy (String_val (rv), uuid, VIR_UUID_BUFLEN);
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+) : uuid string$/) {
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ char uuid[VIR_UUID_STRING_BUFLEN];
+ int r;
+
+ NONBLOCKING (r = $c_name ($1, uuid));
+ CHECK_ERROR (r == -1, \"$c_name\");
+
+ rv = caml_copy_string (uuid);
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+) : bool$/) {
+ "\
+ " . gen_unpack_args ($1) . "
+ int r, b;
+
+ NONBLOCKING (r = $c_name ($1, &b));
+ CHECK_ERROR (r == -1, \"$c_name\");
+
+ CAMLreturn (b ? Val_true : Val_false);
+"
+ } elsif ($sig =~ /^(\w+), bool : unit$/) {
+ "\
+ " . gen_unpack_args ($1) . "
+ int r, b;
+
+ b = bv == Val_true ? 1 : 0;
+
+ NONBLOCKING (r = $c_name ($1, b));
+ CHECK_ERROR (r == -1, \"$c_name\");
+
+ CAMLreturn (Val_unit);
+"
+ } elsif ($sig eq "conn, int : int array") {
+ "\
+ CAMLlocal1 (rv);
+ virConnectPtr conn = Connect_val (connv);
+ int i = Int_val (iv);
+ int *ids, r;
+
+ /* Some libvirt List* functions still throw exceptions if i == 0,
+ * so catch that and return an empty array directly. This changes
+ * the semantics slightly (masking other failures) but it's
+ * unlikely anyone will care. RWMJ 2008/06/10
+ */
+ if (i == 0) {
+ rv = caml_alloc (0, 0);
+ CAMLreturn (rv);
+ }
+
+ ids = malloc (sizeof (*ids) * i);
+ if (ids == NULL)
+ caml_raise_out_of_memory ();
+
+ NONBLOCKING (r = $c_name (conn, ids, i));
+ CHECK_ERROR_CLEANUP (r == -1, free (ids), \"$c_name\");
+
+ rv = caml_alloc (r, 0);
+ for (i = 0; i < r; ++i)
+ Store_field (rv, i, Val_int (ids[i]));
+ free (ids);
+
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+), int : string array$/) {
+ "\
+ CAMLlocal2 (rv, strv);
+ " . gen_unpack_args ($1) . "
+ int i = Int_val (iv);
+ char **names;
+ int r;
+
+ /* Some libvirt List* functions still throw exceptions if i == 0,
+ * so catch that and return an empty array directly. This changes
+ * the semantics slightly (masking other failures) but it's
+ * unlikely anyone will care. RWMJ 2008/06/10
+ */
+ if (i == 0) {
+ rv = caml_alloc (0, 0);
+ CAMLreturn (rv);
+ }
+
+ names = malloc (sizeof (*names) * i);
+ if (names == NULL)
+ caml_raise_out_of_memory ();
+
+ NONBLOCKING (r = $c_name ($1, names, i));
+ CHECK_ERROR_CLEANUP (r == -1, free (names), \"$c_name\");
+
+ rv = caml_alloc (r, 0);
+ for (i = 0; i < r; ++i) {
+ strv = caml_copy_string (names[i]);
+ Store_field (rv, i, strv);
+ free (names[i]);
+ }
+ free (names);
+
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+), 0U? : string$/) {
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ char *r;
+
+ NONBLOCKING (r = $c_name ($1, 0));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ rv = caml_copy_string (r);
+ free (r);
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+), 0U? : unit$/) {
+ "\
+ " . gen_unpack_args ($1) . "
+ int r;
+
+ NONBLOCKING (r = $c_name ($1, 0));
+ CHECK_ERROR (r == -1, \"$c_name\");
+
+ CAMLreturn (Val_unit);
+"
+ } elsif ($sig =~ /^(\w+) : unit$/) {
+ "\
+ " . gen_unpack_args ($1) . "
+ int r;
+
+ NONBLOCKING (r = $c_name ($1));
+ CHECK_ERROR (r == -1, \"$c_name\");
+
+ CAMLreturn (Val_unit);
+"
+ } elsif ($sig =~ /^(\w+) : free$/) {
+ "\
+ " . gen_unpack_args ($1) . "
+ int r;
+
+ NONBLOCKING (r = $c_name ($1));
+ CHECK_ERROR (r == -1, \"$c_name\");
+
+ /* So that we don't double-free in the finalizer: */
+ " . gen_free_arg ($1) . "
+
+ CAMLreturn (Val_unit);
+"
+ } elsif ($sig =~ /^(\w+), string : unit$/) {
+ "\
+ " . gen_unpack_args ($1) . "
+ char *str = String_val (strv);
+ int r;
+
+ NONBLOCKING (r = $c_name ($1, str));
+ CHECK_ERROR (r == -1, \"$c_name\");
+
+ CAMLreturn (Val_unit);
+"
+ } elsif ($sig =~ /^(\w+), string, 0U? : unit$/) {
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ char *str = String_val (strv);
+ int r;
+
+ NONBLOCKING (r = $c_name ($1, str, 0));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ CAMLreturn (Val_unit);
+"
+ } elsif ($sig =~ /^(\w+), string : (\w+)$/) {
+ my $c_ret_type = short_name_to_c_type ($2);
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ char *str = String_val (strv);
+ $c_ret_type r;
+
+ NONBLOCKING (r = $c_name ($1, str));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ " . gen_pack_result ($2) . "
+
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+), string, 0U? : (\w+)$/) {
+ my $c_ret_type = short_name_to_c_type ($2);
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ char *str = String_val (strv);
+ $c_ret_type r;
+
+ NONBLOCKING (r = $c_name ($1, str, 0));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ " . gen_pack_result ($2) . "
+
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+), string, unsigned : (\w+)$/) {
+ my $c_ret_type = short_name_to_c_type ($2);
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ char *str = String_val (strv);
+ unsigned int u = Int_val (uv);
+ $c_ret_type r;
+
+ NONBLOCKING (r = $c_name ($1, str, u));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ " . gen_pack_result ($2) . "
+
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+), (u?)int : unit$/) {
+ my $unsigned = $2 eq "u" ? "unsigned " : "";
+ "\
+ " . gen_unpack_args ($1) . "
+ ${unsigned}int i = Int_val (iv);
+ int r;
+
+ NONBLOCKING (r = $c_name ($1, i));
+ CHECK_ERROR (r == -1, \"$c_name\");
+
+ CAMLreturn (Val_unit);
+"
+ } elsif ($sig =~ /^(\w+), (u?)int : (\w+)$/) {
+ my $c_ret_type = short_name_to_c_type ($3);
+ my $unsigned = $2 eq "u" ? "unsigned " : "";
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ ${unsigned}int i = Int_val (iv);
+ $c_ret_type r;
+
+ NONBLOCKING (r = $c_name ($1, i));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ " . gen_pack_result ($3) . "
+
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+), uuid : (\w+)$/) {
+ my $c_ret_type = short_name_to_c_type ($2);
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ unsigned char *uuid = (unsigned char *) String_val (uuidv);
+ $c_ret_type r;
+
+ NONBLOCKING (r = $c_name ($1, uuid));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ " . gen_pack_result ($2) . "
+
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+), 0U? : (\w+)$/) {
+ my $c_ret_type = short_name_to_c_type ($2);
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ $c_ret_type r;
+
+ NONBLOCKING (r = $c_name ($1, 0));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ " . gen_pack_result ($2) . "
+
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+) : (\w+)$/) {
+ my $c_ret_type = short_name_to_c_type ($2);
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ $c_ret_type r;
+
+ NONBLOCKING (r = $c_name ($1));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ " . gen_pack_result ($2) . "
+
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+), string : (\w+) from (\w+)$/) {
+ my $c_ret_type = short_name_to_c_type ($2);
+ "\
+ CAMLlocal2 (rv, connv);
+ " . gen_unpack_args ($1) . "
+ char *str = String_val (strv);
+ $c_ret_type r;
+
+ NONBLOCKING (r = $c_name ($1, str));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ connv = Field ($3v, 1);
+ " . gen_pack_result ($2) . "
+
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+), string, 0U? : (\w+) from (\w+)$/) {
+ my $c_ret_type = short_name_to_c_type ($2);
+ "\
+ CAMLlocal2 (rv, connv);
+ " . gen_unpack_args ($1) . "
+ char *str = String_val (strv);
+ $c_ret_type r;
+
+ NONBLOCKING (r = $c_name ($1, str, 0));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ connv = Field ($3v, 1);
+ " . gen_pack_result ($2) . "
+
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+), 0U? : (\w+) from (\w+)$/) {
+ my $c_ret_type = short_name_to_c_type ($2);
+ "\
+ CAMLlocal2 (rv, connv);
+ " . gen_unpack_args ($1) . "
+ $c_ret_type r;
+
+ NONBLOCKING (r = $c_name ($1, 0));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ connv = Field ($3v, 1);
+ " . gen_pack_result ($2) . "
+
+ CAMLreturn (rv);
+"
+ } elsif ($sig =~ /^(\w+) : (\w+) from (\w+)$/) {
+ my $c_ret_type = short_name_to_c_type ($2);
+ "\
+ CAMLlocal2 (rv, connv);
+ " . gen_unpack_args ($1) . "
+ $c_ret_type r;
+
+ NONBLOCKING (r = $c_name ($1));
+ CHECK_ERROR (!r, \"$c_name\");
+
+ connv = Field ($3v, 1);
+ " . gen_pack_result ($2) . "
+
+ CAMLreturn (rv);
+"
+ } else {
+ die "unknown signature $sig"
+ }
+}
+
+# Generate each function.
+
+foreach my $function (@functions) {
+ my $c_name = $function->{name};
+ my $sig = $function->{sig};
+
+ #print "generating $c_name with sig \"$sig\" ...\n";
+
+ #my $is_pool_func = $c_name =~ /^virStoragePool/;
+ #my $is_vol_func = $c_name =~ /^virStorageVol/;
+
+ # Generate an equivalent C-external name for the function, unless
+ # one is defined already.
+ my $c_external_name;
+ if (exists ($function->{c_external_name})) {
+ $c_external_name = $function->{c_external_name};
+ } elsif ($c_name =~ /^vir/) {
+ $c_external_name = substr $c_name, 3;
+ $c_external_name = camel_case_to_underscores ($c_external_name);
+ $c_external_name = "ocaml_libvirt_" . $c_external_name;
+ } else {
+ die "cannot convert c_name $c_name to c_external_name"
+ }
+
+ print F <<END;
+/* Automatically generated binding for $c_name.
+ * In generator.pl this function has signature "$sig".
+ */
+
+END
+
+ my @arg_names = gen_arg_names ($sig);
+ my $nr_arg_names = scalar @arg_names;
+ my $arg_names = join ", ", @arg_names;
+ my $arg_names_as_values = join (", ", map { "value $_"
} @arg_names);
+
+ # Generate the start of the function, arguments.
+ print F <<END;
+CAMLprim value
+$c_external_name ($arg_names_as_values)
+{
+ CAMLparam$nr_arg_names ($arg_names);
+END
+
+ # Generate the internals of the function.
+ print F (gen_c_code ($sig, $c_name));
+
+ # Finish off the function.
+ print F <<END;
+}
+
+END
+}
+
+#----------------------------------------------------------------------
+
+# Unimplemented functions.
+
+if (@unimplemented) {
+ printf "$0: warning: %d unimplemented functions\n", scalar
(@unimplemented);
+
+ print F <<'END';
+/* The following functions are unimplemented and always fail.
+ * See generator.pl '@unimplemented'
+ */
+
+END
+
+ foreach my $c_external_name (@unimplemented) {
+ print F <<END;
+CAMLprim value
+$c_external_name ()
+{
+ failwith ("$c_external_name is unimplemented");
+}
+
+END
+ } # end foreach
+} # end if @unimplemented
+
+#----------------------------------------------------------------------
+
+# Write the epilogue.
+
+print F <<'END';
+#include "libvirt_c_epilogue.c"
+
+/* EOF */
+END
+
+close F;
+print "$0: written $filename\n"
+
diff --git a/common/mllibvirt/libvirt.README b/common/mllibvirt/libvirt.README
new file mode 100644
index 000000000..a151bbc6b
--- /dev/null
+++ b/common/mllibvirt/libvirt.README
@@ -0,0 +1,9 @@
+The files generator.pl, libvirt_c_epilogue.c, libvirt_c_oneoffs.c,
+libvirt_c_prologue.c, libvirt.ml, and libvirt.mli come from the
+ocaml-libvirt library:
+
+ https://libvirt.org/git/?p=libvirt-ocaml.git
+
+which is released under a compatible license. We try to keep them
+identical, so if you make changes to these files then you must also
+submit the changes to ocaml-libvirt, and vice versa.
diff --git a/common/mllibvirt/libvirt.ml b/common/mllibvirt/libvirt.ml
new file mode 100644
index 000000000..49ccc3eaf
--- /dev/null
+++ b/common/mllibvirt/libvirt.ml
@@ -0,0 +1,1661 @@
+(* OCaml bindings for libvirt.
+ (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc.
+ https://libvirt.org/
+
+ This library 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; either
+ version 2 of the License, or (at your option) any later version,
+ with the OCaml linking exception described in ../COPYING.LIB.
+
+ This library 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.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+*)
+
+type uuid = string
+
+type xml = string
+
+type filename = string
+
+external get_version : ?driver:string -> unit -> int * int =
"ocaml_libvirt_get_version"
+
+let uuid_length = 16
+let uuid_string_length = 36
+
+(*
https://caml.inria.fr/pub/ml-archives/caml-list/2004/07/80683af867cce6bf8fff273973f70c95.en.html
*)
+type rw = [`R|`W]
+type ro = [`R]
+
+module Connect +struct
+ type 'rw t
+
+ type node_info = {
+ model : string;
+ memory : int64;
+ cpus : int;
+ mhz : int;
+ nodes : int;
+ sockets : int;
+ cores : int;
+ threads : int;
+ }
+
+ type credential_type + | CredentialUsername
+ | CredentialAuthname
+ | CredentialLanguage
+ | CredentialCnonce
+ | CredentialPassphrase
+ | CredentialEchoprompt
+ | CredentialNoechoprompt
+ | CredentialRealm
+ | CredentialExternal
+
+ type credential = {
+ typ : credential_type;
+ prompt : string;
+ challenge : string option;
+ defresult : string option;
+ }
+
+ type auth = {
+ credtype : credential_type list;
+ cb : (credential list -> string option list);
+ }
+
+ type list_flag + | ListNoState | ListRunning | ListBlocked
+ | ListPaused | ListShutdown | ListShutoff | ListCrashed
+ | ListActive
+ | ListInactive
+ | ListAll
+
+ external connect : ?name:string -> unit -> rw t =
"ocaml_libvirt_connect_open"
+ external connect_readonly : ?name:string -> unit -> ro t =
"ocaml_libvirt_connect_open_readonly"
+ external connect_auth : ?name:string -> auth -> rw t =
"ocaml_libvirt_connect_open_auth"
+ external connect_auth_readonly : ?name:string -> auth -> ro t =
"ocaml_libvirt_connect_open_auth_readonly"
+ external close : [>`R] t -> unit =
"ocaml_libvirt_connect_close"
+ external get_type : [>`R] t -> string =
"ocaml_libvirt_connect_get_type"
+ external get_version : [>`R] t -> int =
"ocaml_libvirt_connect_get_version"
+ external get_hostname : [>`R] t -> string =
"ocaml_libvirt_connect_get_hostname"
+ external get_uri : [>`R] t -> string =
"ocaml_libvirt_connect_get_uri"
+ external get_max_vcpus : [>`R] t -> ?type_:string -> unit -> int
= "ocaml_libvirt_connect_get_max_vcpus"
+ external list_domains : [>`R] t -> int -> int array =
"ocaml_libvirt_connect_list_domains"
+ external num_of_domains : [>`R] t -> int =
"ocaml_libvirt_connect_num_of_domains"
+ external get_capabilities : [>`R] t -> xml =
"ocaml_libvirt_connect_get_capabilities"
+ external num_of_defined_domains : [>`R] t -> int =
"ocaml_libvirt_connect_num_of_defined_domains"
+ external list_defined_domains : [>`R] t -> int -> string array =
"ocaml_libvirt_connect_list_defined_domains"
+ external num_of_networks : [>`R] t -> int =
"ocaml_libvirt_connect_num_of_networks"
+ external list_networks : [>`R] t -> int -> string array =
"ocaml_libvirt_connect_list_networks"
+ external num_of_defined_networks : [>`R] t -> int =
"ocaml_libvirt_connect_num_of_defined_networks"
+ external list_defined_networks : [>`R] t -> int -> string array =
"ocaml_libvirt_connect_list_defined_networks"
+ external num_of_pools : [>`R] t -> int =
"ocaml_libvirt_connect_num_of_storage_pools"
+ external list_pools : [>`R] t -> int -> string array =
"ocaml_libvirt_connect_list_storage_pools"
+ external num_of_defined_pools : [>`R] t -> int =
"ocaml_libvirt_connect_num_of_defined_storage_pools"
+ external list_defined_pools : [>`R] t -> int -> string array =
"ocaml_libvirt_connect_list_defined_storage_pools"
+ external num_of_secrets : [>`R] t -> int =
"ocaml_libvirt_connect_num_of_secrets"
+ external list_secrets : [>`R] t -> int -> string array =
"ocaml_libvirt_connect_list_secrets"
+
+ external get_node_info : [>`R] t -> node_info =
"ocaml_libvirt_connect_get_node_info"
+ external node_get_free_memory : [> `R] t -> int64 =
"ocaml_libvirt_connect_node_get_free_memory"
+ external node_get_cells_free_memory : [> `R] t -> int -> int ->
int64 array = "ocaml_libvirt_connect_node_get_cells_free_memory"
+
+ (* See VIR_NODEINFO_MAXCPUS macro defined in <libvirt.h>. *)
+ let maxcpus_of_node_info { nodes = nodes; sockets = sockets;
+ cores = cores; threads = threads } + nodes * sockets * cores *
threads
+
+ (* See VIR_CPU_MAPLEN macro defined in <libvirt.h>. *)
+ let cpumaplen nr_cpus + (nr_cpus + 7) / 8
+
+ (* See VIR_USE_CPU, VIR_UNUSE_CPU, VIR_CPU_USABLE macros defined in
<libvirt.h>. *)
+ let use_cpu cpumap cpu + Bytes.set cpumap (cpu/8)
+ (Char.chr (Char.code (Bytes.get cpumap (cpu/8)) lor (1 lsl (cpu mod 8))))
+ let unuse_cpu cpumap cpu + Bytes.set cpumap (cpu/8)
+ (Char.chr (Char.code (Bytes.get cpumap (cpu/8)) land (lnot (1 lsl (cpu
mod 8)))))
+ let cpu_usable cpumaps maplen vcpu cpu + Char.code (Bytes.get cpumaps
(vcpu*maplen + cpu/8)) land (1 lsl (cpu mod 8)) <> 0
+
+ external set_keep_alive : [>`R] t -> int -> int -> unit =
"ocaml_libvirt_connect_set_keep_alive"
+
+ (* Internal API needed for get_auth_default. *)
+ external _credtypes_from_auth_default : unit -> credential_type list =
"ocaml_libvirt_connect_credtypes_from_auth_default"
+ external _call_auth_default_callback : credential list -> string option
list = "ocaml_libvirt_connect_call_auth_default_callback"
+ let get_auth_default () + {
+ credtype = _credtypes_from_auth_default ();
+ cb = _call_auth_default_callback;
+ }
+
+ external const : [>`R] t -> ro t = "%identity"
+end
+
+module Virterror +struct
+ type code + | VIR_ERR_OK
+ | VIR_ERR_INTERNAL_ERROR
+ | VIR_ERR_NO_MEMORY
+ | VIR_ERR_NO_SUPPORT
+ | VIR_ERR_UNKNOWN_HOST
+ | VIR_ERR_NO_CONNECT
+ | VIR_ERR_INVALID_CONN
+ | VIR_ERR_INVALID_DOMAIN
+ | VIR_ERR_INVALID_ARG
+ | VIR_ERR_OPERATION_FAILED
+ | VIR_ERR_GET_FAILED
+ | VIR_ERR_POST_FAILED
+ | VIR_ERR_HTTP_ERROR
+ | VIR_ERR_SEXPR_SERIAL
+ | VIR_ERR_NO_XEN
+ | VIR_ERR_XEN_CALL
+ | VIR_ERR_OS_TYPE
+ | VIR_ERR_NO_KERNEL
+ | VIR_ERR_NO_ROOT
+ | VIR_ERR_NO_SOURCE
+ | VIR_ERR_NO_TARGET
+ | VIR_ERR_NO_NAME
+ | VIR_ERR_NO_OS
+ | VIR_ERR_NO_DEVICE
+ | VIR_ERR_NO_XENSTORE
+ | VIR_ERR_DRIVER_FULL
+ | VIR_ERR_CALL_FAILED
+ | VIR_ERR_XML_ERROR
+ | VIR_ERR_DOM_EXIST
+ | VIR_ERR_OPERATION_DENIED
+ | VIR_ERR_OPEN_FAILED
+ | VIR_ERR_READ_FAILED
+ | VIR_ERR_PARSE_FAILED
+ | VIR_ERR_CONF_SYNTAX
+ | VIR_ERR_WRITE_FAILED
+ | VIR_ERR_XML_DETAIL
+ | VIR_ERR_INVALID_NETWORK
+ | VIR_ERR_NETWORK_EXIST
+ | VIR_ERR_SYSTEM_ERROR
+ | VIR_ERR_RPC
+ | VIR_ERR_GNUTLS_ERROR
+ | VIR_WAR_NO_NETWORK
+ | VIR_ERR_NO_DOMAIN
+ | VIR_ERR_NO_NETWORK
+ | VIR_ERR_INVALID_MAC
+ | VIR_ERR_AUTH_FAILED
+ | VIR_ERR_INVALID_STORAGE_POOL
+ | VIR_ERR_INVALID_STORAGE_VOL
+ | VIR_WAR_NO_STORAGE
+ | VIR_ERR_NO_STORAGE_POOL
+ | VIR_ERR_NO_STORAGE_VOL
+ | VIR_WAR_NO_NODE
+ | VIR_ERR_INVALID_NODE_DEVICE
+ | VIR_ERR_NO_NODE_DEVICE
+ | VIR_ERR_NO_SECURITY_MODEL
+ | VIR_ERR_OPERATION_INVALID
+ | VIR_WAR_NO_INTERFACE
+ | VIR_ERR_NO_INTERFACE
+ | VIR_ERR_INVALID_INTERFACE
+ | VIR_ERR_MULTIPLE_INTERFACES
+ | VIR_WAR_NO_NWFILTER
+ | VIR_ERR_INVALID_NWFILTER
+ | VIR_ERR_NO_NWFILTER
+ | VIR_ERR_BUILD_FIREWALL
+ | VIR_WAR_NO_SECRET
+ | VIR_ERR_INVALID_SECRET
+ | VIR_ERR_NO_SECRET
+ | VIR_ERR_CONFIG_UNSUPPORTED
+ | VIR_ERR_OPERATION_TIMEOUT
+ | VIR_ERR_MIGRATE_PERSIST_FAILED
+ | VIR_ERR_HOOK_SCRIPT_FAILED
+ | VIR_ERR_INVALID_DOMAIN_SNAPSHOT
+ | VIR_ERR_NO_DOMAIN_SNAPSHOT
+ | VIR_ERR_INVALID_STREAM
+ | VIR_ERR_ARGUMENT_UNSUPPORTED
+ | VIR_ERR_STORAGE_PROBE_FAILED
+ | VIR_ERR_STORAGE_POOL_BUILT
+ | VIR_ERR_SNAPSHOT_REVERT_RISKY
+ | VIR_ERR_OPERATION_ABORTED
+ | VIR_ERR_AUTH_CANCELLED
+ | VIR_ERR_NO_DOMAIN_METADATA
+ | VIR_ERR_MIGRATE_UNSAFE
+ | VIR_ERR_OVERFLOW
+ | VIR_ERR_BLOCK_COPY_ACTIVE
+ | VIR_ERR_OPERATION_UNSUPPORTED
+ | VIR_ERR_SSH
+ | VIR_ERR_AGENT_UNRESPONSIVE
+ | VIR_ERR_RESOURCE_BUSY
+ | VIR_ERR_ACCESS_DENIED
+ | VIR_ERR_DBUS_SERVICE
+ | VIR_ERR_STORAGE_VOL_EXIST
+ | VIR_ERR_CPU_INCOMPATIBLE
+ | VIR_ERR_XML_INVALID_SCHEMA
+ | VIR_ERR_MIGRATE_FINISH_OK
+ | VIR_ERR_AUTH_UNAVAILABLE
+ | VIR_ERR_NO_SERVER
+ | VIR_ERR_NO_CLIENT
+ | VIR_ERR_AGENT_UNSYNCED
+ | VIR_ERR_LIBSSH
+ | VIR_ERR_DEVICE_MISSING
+ | VIR_ERR_INVALID_NWFILTER_BINDING
+ | VIR_ERR_NO_NWFILTER_BINDING
+ | VIR_ERR_UNKNOWN of int
+
+ let string_of_code = function
+ | VIR_ERR_OK -> "VIR_ERR_OK"
+ | VIR_ERR_INTERNAL_ERROR -> "VIR_ERR_INTERNAL_ERROR"
+ | VIR_ERR_NO_MEMORY -> "VIR_ERR_NO_MEMORY"
+ | VIR_ERR_NO_SUPPORT -> "VIR_ERR_NO_SUPPORT"
+ | VIR_ERR_UNKNOWN_HOST -> "VIR_ERR_UNKNOWN_HOST"
+ | VIR_ERR_NO_CONNECT -> "VIR_ERR_NO_CONNECT"
+ | VIR_ERR_INVALID_CONN -> "VIR_ERR_INVALID_CONN"
+ | VIR_ERR_INVALID_DOMAIN -> "VIR_ERR_INVALID_DOMAIN"
+ | VIR_ERR_INVALID_ARG -> "VIR_ERR_INVALID_ARG"
+ | VIR_ERR_OPERATION_FAILED -> "VIR_ERR_OPERATION_FAILED"
+ | VIR_ERR_GET_FAILED -> "VIR_ERR_GET_FAILED"
+ | VIR_ERR_POST_FAILED -> "VIR_ERR_POST_FAILED"
+ | VIR_ERR_HTTP_ERROR -> "VIR_ERR_HTTP_ERROR"
+ | VIR_ERR_SEXPR_SERIAL -> "VIR_ERR_SEXPR_SERIAL"
+ | VIR_ERR_NO_XEN -> "VIR_ERR_NO_XEN"
+ | VIR_ERR_XEN_CALL -> "VIR_ERR_XEN_CALL"
+ | VIR_ERR_OS_TYPE -> "VIR_ERR_OS_TYPE"
+ | VIR_ERR_NO_KERNEL -> "VIR_ERR_NO_KERNEL"
+ | VIR_ERR_NO_ROOT -> "VIR_ERR_NO_ROOT"
+ | VIR_ERR_NO_SOURCE -> "VIR_ERR_NO_SOURCE"
+ | VIR_ERR_NO_TARGET -> "VIR_ERR_NO_TARGET"
+ | VIR_ERR_NO_NAME -> "VIR_ERR_NO_NAME"
+ | VIR_ERR_NO_OS -> "VIR_ERR_NO_OS"
+ | VIR_ERR_NO_DEVICE -> "VIR_ERR_NO_DEVICE"
+ | VIR_ERR_NO_XENSTORE -> "VIR_ERR_NO_XENSTORE"
+ | VIR_ERR_DRIVER_FULL -> "VIR_ERR_DRIVER_FULL"
+ | VIR_ERR_CALL_FAILED -> "VIR_ERR_CALL_FAILED"
+ | VIR_ERR_XML_ERROR -> "VIR_ERR_XML_ERROR"
+ | VIR_ERR_DOM_EXIST -> "VIR_ERR_DOM_EXIST"
+ | VIR_ERR_OPERATION_DENIED -> "VIR_ERR_OPERATION_DENIED"
+ | VIR_ERR_OPEN_FAILED -> "VIR_ERR_OPEN_FAILED"
+ | VIR_ERR_READ_FAILED -> "VIR_ERR_READ_FAILED"
+ | VIR_ERR_PARSE_FAILED -> "VIR_ERR_PARSE_FAILED"
+ | VIR_ERR_CONF_SYNTAX -> "VIR_ERR_CONF_SYNTAX"
+ | VIR_ERR_WRITE_FAILED -> "VIR_ERR_WRITE_FAILED"
+ | VIR_ERR_XML_DETAIL -> "VIR_ERR_XML_DETAIL"
+ | VIR_ERR_INVALID_NETWORK -> "VIR_ERR_INVALID_NETWORK"
+ | VIR_ERR_NETWORK_EXIST -> "VIR_ERR_NETWORK_EXIST"
+ | VIR_ERR_SYSTEM_ERROR -> "VIR_ERR_SYSTEM_ERROR"
+ | VIR_ERR_RPC -> "VIR_ERR_RPC"
+ | VIR_ERR_GNUTLS_ERROR -> "VIR_ERR_GNUTLS_ERROR"
+ | VIR_WAR_NO_NETWORK -> "VIR_WAR_NO_NETWORK"
+ | VIR_ERR_NO_DOMAIN -> "VIR_ERR_NO_DOMAIN"
+ | VIR_ERR_NO_NETWORK -> "VIR_ERR_NO_NETWORK"
+ | VIR_ERR_INVALID_MAC -> "VIR_ERR_INVALID_MAC"
+ | VIR_ERR_AUTH_FAILED -> "VIR_ERR_AUTH_FAILED"
+ | VIR_ERR_INVALID_STORAGE_POOL ->
"VIR_ERR_INVALID_STORAGE_POOL"
+ | VIR_ERR_INVALID_STORAGE_VOL -> "VIR_ERR_INVALID_STORAGE_VOL"
+ | VIR_WAR_NO_STORAGE -> "VIR_WAR_NO_STORAGE"
+ | VIR_ERR_NO_STORAGE_POOL -> "VIR_ERR_NO_STORAGE_POOL"
+ | VIR_ERR_NO_STORAGE_VOL -> "VIR_ERR_NO_STORAGE_VOL"
+ | VIR_WAR_NO_NODE -> "VIR_WAR_NO_NODE"
+ | VIR_ERR_INVALID_NODE_DEVICE -> "VIR_ERR_INVALID_NODE_DEVICE"
+ | VIR_ERR_NO_NODE_DEVICE -> "VIR_ERR_NO_NODE_DEVICE"
+ | VIR_ERR_NO_SECURITY_MODEL -> "VIR_ERR_NO_SECURITY_MODEL"
+ | VIR_ERR_OPERATION_INVALID -> "VIR_ERR_OPERATION_INVALID"
+ | VIR_WAR_NO_INTERFACE -> "VIR_WAR_NO_INTERFACE"
+ | VIR_ERR_NO_INTERFACE -> "VIR_ERR_NO_INTERFACE"
+ | VIR_ERR_INVALID_INTERFACE -> "VIR_ERR_INVALID_INTERFACE"
+ | VIR_ERR_MULTIPLE_INTERFACES -> "VIR_ERR_MULTIPLE_INTERFACES"
+ | VIR_WAR_NO_NWFILTER -> "VIR_WAR_NO_NWFILTER"
+ | VIR_ERR_INVALID_NWFILTER -> "VIR_ERR_INVALID_NWFILTER"
+ | VIR_ERR_NO_NWFILTER -> "VIR_ERR_NO_NWFILTER"
+ | VIR_ERR_BUILD_FIREWALL -> "VIR_ERR_BUILD_FIREWALL"
+ | VIR_WAR_NO_SECRET -> "VIR_WAR_NO_SECRET"
+ | VIR_ERR_INVALID_SECRET -> "VIR_ERR_INVALID_SECRET"
+ | VIR_ERR_NO_SECRET -> "VIR_ERR_NO_SECRET"
+ | VIR_ERR_CONFIG_UNSUPPORTED -> "VIR_ERR_CONFIG_UNSUPPORTED"
+ | VIR_ERR_OPERATION_TIMEOUT -> "VIR_ERR_OPERATION_TIMEOUT"
+ | VIR_ERR_MIGRATE_PERSIST_FAILED ->
"VIR_ERR_MIGRATE_PERSIST_FAILED"
+ | VIR_ERR_HOOK_SCRIPT_FAILED -> "VIR_ERR_HOOK_SCRIPT_FAILED"
+ | VIR_ERR_INVALID_DOMAIN_SNAPSHOT ->
"VIR_ERR_INVALID_DOMAIN_SNAPSHOT"
+ | VIR_ERR_NO_DOMAIN_SNAPSHOT -> "VIR_ERR_NO_DOMAIN_SNAPSHOT"
+ | VIR_ERR_INVALID_STREAM -> "VIR_ERR_INVALID_STREAM"
+ | VIR_ERR_ARGUMENT_UNSUPPORTED ->
"VIR_ERR_ARGUMENT_UNSUPPORTED"
+ | VIR_ERR_STORAGE_PROBE_FAILED ->
"VIR_ERR_STORAGE_PROBE_FAILED"
+ | VIR_ERR_STORAGE_POOL_BUILT -> "VIR_ERR_STORAGE_POOL_BUILT"
+ | VIR_ERR_SNAPSHOT_REVERT_RISKY ->
"VIR_ERR_SNAPSHOT_REVERT_RISKY"
+ | VIR_ERR_OPERATION_ABORTED -> "VIR_ERR_OPERATION_ABORTED"
+ | VIR_ERR_AUTH_CANCELLED -> "VIR_ERR_AUTH_CANCELLED"
+ | VIR_ERR_NO_DOMAIN_METADATA -> "VIR_ERR_NO_DOMAIN_METADATA"
+ | VIR_ERR_MIGRATE_UNSAFE -> "VIR_ERR_MIGRATE_UNSAFE"
+ | VIR_ERR_OVERFLOW -> "VIR_ERR_OVERFLOW"
+ | VIR_ERR_BLOCK_COPY_ACTIVE -> "VIR_ERR_BLOCK_COPY_ACTIVE"
+ | VIR_ERR_OPERATION_UNSUPPORTED ->
"VIR_ERR_OPERATION_UNSUPPORTED"
+ | VIR_ERR_SSH -> "VIR_ERR_SSH"
+ | VIR_ERR_AGENT_UNRESPONSIVE -> "VIR_ERR_AGENT_UNRESPONSIVE"
+ | VIR_ERR_RESOURCE_BUSY -> "VIR_ERR_RESOURCE_BUSY"
+ | VIR_ERR_ACCESS_DENIED -> "VIR_ERR_ACCESS_DENIED"
+ | VIR_ERR_DBUS_SERVICE -> "VIR_ERR_DBUS_SERVICE"
+ | VIR_ERR_STORAGE_VOL_EXIST -> "VIR_ERR_STORAGE_VOL_EXIST"
+ | VIR_ERR_CPU_INCOMPATIBLE -> "VIR_ERR_CPU_INCOMPATIBLE"
+ | VIR_ERR_XML_INVALID_SCHEMA -> "VIR_ERR_XML_INVALID_SCHEMA"
+ | VIR_ERR_MIGRATE_FINISH_OK -> "VIR_ERR_MIGRATE_FINISH_OK"
+ | VIR_ERR_AUTH_UNAVAILABLE -> "VIR_ERR_AUTH_UNAVAILABLE"
+ | VIR_ERR_NO_SERVER -> "VIR_ERR_NO_SERVER"
+ | VIR_ERR_NO_CLIENT -> "VIR_ERR_NO_CLIENT"
+ | VIR_ERR_AGENT_UNSYNCED -> "VIR_ERR_AGENT_UNSYNCED"
+ | VIR_ERR_LIBSSH -> "VIR_ERR_LIBSSH"
+ | VIR_ERR_DEVICE_MISSING -> "VIR_ERR_DEVICE_MISSING"
+ | VIR_ERR_INVALID_NWFILTER_BINDING ->
"VIR_ERR_INVALID_NWFILTER_BINDING"
+ | VIR_ERR_NO_NWFILTER_BINDING -> "VIR_ERR_NO_NWFILTER_BINDING"
+ | VIR_ERR_UNKNOWN i -> "VIR_ERR_" ^ string_of_int i
+
+ type domain + | VIR_FROM_NONE
+ | VIR_FROM_XEN
+ | VIR_FROM_XEND
+ | VIR_FROM_XENSTORE
+ | VIR_FROM_SEXPR
+ | VIR_FROM_XML
+ | VIR_FROM_DOM
+ | VIR_FROM_RPC
+ | VIR_FROM_PROXY
+ | VIR_FROM_CONF
+ | VIR_FROM_QEMU
+ | VIR_FROM_NET
+ | VIR_FROM_TEST
+ | VIR_FROM_REMOTE
+ | VIR_FROM_OPENVZ
+ | VIR_FROM_XENXM
+ | VIR_FROM_STATS_LINUX
+ | VIR_FROM_LXC
+ | VIR_FROM_STORAGE
+ | VIR_FROM_NETWORK
+ | VIR_FROM_DOMAIN
+ | VIR_FROM_UML
+ | VIR_FROM_NODEDEV
+ | VIR_FROM_XEN_INOTIFY
+ | VIR_FROM_SECURITY
+ | VIR_FROM_VBOX
+ | VIR_FROM_INTERFACE
+ | VIR_FROM_ONE
+ | VIR_FROM_ESX
+ | VIR_FROM_PHYP
+ | VIR_FROM_SECRET
+ | VIR_FROM_CPU
+ | VIR_FROM_XENAPI
+ | VIR_FROM_NWFILTER
+ | VIR_FROM_HOOK
+ | VIR_FROM_DOMAIN_SNAPSHOT
+ | VIR_FROM_AUDIT
+ | VIR_FROM_SYSINFO
+ | VIR_FROM_STREAMS
+ | VIR_FROM_VMWARE
+ | VIR_FROM_EVENT
+ | VIR_FROM_LIBXL
+ | VIR_FROM_LOCKING
+ | VIR_FROM_HYPERV
+ | VIR_FROM_CAPABILITIES
+ | VIR_FROM_URI
+ | VIR_FROM_AUTH
+ | VIR_FROM_DBUS
+ | VIR_FROM_PARALLELS
+ | VIR_FROM_DEVICE
+ | VIR_FROM_SSH
+ | VIR_FROM_LOCKSPACE
+ | VIR_FROM_INITCTL
+ | VIR_FROM_IDENTITY
+ | VIR_FROM_CGROUP
+ | VIR_FROM_ACCESS
+ | VIR_FROM_SYSTEMD
+ | VIR_FROM_BHYVE
+ | VIR_FROM_CRYPTO
+ | VIR_FROM_FIREWALL
+ | VIR_FROM_POLKIT
+ | VIR_FROM_THREAD
+ | VIR_FROM_ADMIN
+ | VIR_FROM_LOGGING
+ | VIR_FROM_XENXL
+ | VIR_FROM_PERF
+ | VIR_FROM_LIBSSH
+ | VIR_FROM_RESCTRL
+ | VIR_FROM_UNKNOWN of int
+
+ let string_of_domain = function
+ | VIR_FROM_NONE -> "VIR_FROM_NONE"
+ | VIR_FROM_XEN -> "VIR_FROM_XEN"
+ | VIR_FROM_XEND -> "VIR_FROM_XEND"
+ | VIR_FROM_XENSTORE -> "VIR_FROM_XENSTORE"
+ | VIR_FROM_SEXPR -> "VIR_FROM_SEXPR"
+ | VIR_FROM_XML -> "VIR_FROM_XML"
+ | VIR_FROM_DOM -> "VIR_FROM_DOM"
+ | VIR_FROM_RPC -> "VIR_FROM_RPC"
+ | VIR_FROM_PROXY -> "VIR_FROM_PROXY"
+ | VIR_FROM_CONF -> "VIR_FROM_CONF"
+ | VIR_FROM_QEMU -> "VIR_FROM_QEMU"
+ | VIR_FROM_NET -> "VIR_FROM_NET"
+ | VIR_FROM_TEST -> "VIR_FROM_TEST"
+ | VIR_FROM_REMOTE -> "VIR_FROM_REMOTE"
+ | VIR_FROM_OPENVZ -> "VIR_FROM_OPENVZ"
+ | VIR_FROM_XENXM -> "VIR_FROM_XENXM"
+ | VIR_FROM_STATS_LINUX -> "VIR_FROM_STATS_LINUX"
+ | VIR_FROM_LXC -> "VIR_FROM_LXC"
+ | VIR_FROM_STORAGE -> "VIR_FROM_STORAGE"
+ | VIR_FROM_NETWORK -> "VIR_FROM_NETWORK"
+ | VIR_FROM_DOMAIN -> "VIR_FROM_DOMAIN"
+ | VIR_FROM_UML -> "VIR_FROM_UML"
+ | VIR_FROM_NODEDEV -> "VIR_FROM_NODEDEV"
+ | VIR_FROM_XEN_INOTIFY -> "VIR_FROM_XEN_INOTIFY"
+ | VIR_FROM_SECURITY -> "VIR_FROM_SECURITY"
+ | VIR_FROM_VBOX -> "VIR_FROM_VBOX"
+ | VIR_FROM_INTERFACE -> "VIR_FROM_INTERFACE"
+ | VIR_FROM_ONE -> "VIR_FROM_ONE"
+ | VIR_FROM_ESX -> "VIR_FROM_ESX"
+ | VIR_FROM_PHYP -> "VIR_FROM_PHYP"
+ | VIR_FROM_SECRET -> "VIR_FROM_SECRET"
+ | VIR_FROM_CPU -> "VIR_FROM_CPU"
+ | VIR_FROM_XENAPI -> "VIR_FROM_XENAPI"
+ | VIR_FROM_NWFILTER -> "VIR_FROM_NWFILTER"
+ | VIR_FROM_HOOK -> "VIR_FROM_HOOK"
+ | VIR_FROM_DOMAIN_SNAPSHOT -> "VIR_FROM_DOMAIN_SNAPSHOT"
+ | VIR_FROM_AUDIT -> "VIR_FROM_AUDIT"
+ | VIR_FROM_SYSINFO -> "VIR_FROM_SYSINFO"
+ | VIR_FROM_STREAMS -> "VIR_FROM_STREAMS"
+ | VIR_FROM_VMWARE -> "VIR_FROM_VMWARE"
+ | VIR_FROM_EVENT -> "VIR_FROM_EVENT"
+ | VIR_FROM_LIBXL -> "VIR_FROM_LIBXL"
+ | VIR_FROM_LOCKING -> "VIR_FROM_LOCKING"
+ | VIR_FROM_HYPERV -> "VIR_FROM_HYPERV"
+ | VIR_FROM_CAPABILITIES -> "VIR_FROM_CAPABILITIES"
+ | VIR_FROM_URI -> "VIR_FROM_URI"
+ | VIR_FROM_AUTH -> "VIR_FROM_AUTH"
+ | VIR_FROM_DBUS -> "VIR_FROM_DBUS"
+ | VIR_FROM_PARALLELS -> "VIR_FROM_PARALLELS"
+ | VIR_FROM_DEVICE -> "VIR_FROM_DEVICE"
+ | VIR_FROM_SSH -> "VIR_FROM_SSH"
+ | VIR_FROM_LOCKSPACE -> "VIR_FROM_LOCKSPACE"
+ | VIR_FROM_INITCTL -> "VIR_FROM_INITCTL"
+ | VIR_FROM_IDENTITY -> "VIR_FROM_IDENTITY"
+ | VIR_FROM_CGROUP -> "VIR_FROM_CGROUP"
+ | VIR_FROM_ACCESS -> "VIR_FROM_ACCESS"
+ | VIR_FROM_SYSTEMD -> "VIR_FROM_SYSTEMD"
+ | VIR_FROM_BHYVE -> "VIR_FROM_BHYVE"
+ | VIR_FROM_CRYPTO -> "VIR_FROM_CRYPTO"
+ | VIR_FROM_FIREWALL -> "VIR_FROM_FIREWALL"
+ | VIR_FROM_POLKIT -> "VIR_FROM_POLKIT"
+ | VIR_FROM_THREAD -> "VIR_FROM_THREAD"
+ | VIR_FROM_ADMIN -> "VIR_FROM_ADMIN"
+ | VIR_FROM_LOGGING -> "VIR_FROM_LOGGING"
+ | VIR_FROM_XENXL -> "VIR_FROM_XENXL"
+ | VIR_FROM_PERF -> "VIR_FROM_PERF"
+ | VIR_FROM_LIBSSH -> "VIR_FROM_LIBSSH"
+ | VIR_FROM_RESCTRL -> "VIR_FROM_RESCTRL"
+ | VIR_FROM_UNKNOWN i -> "VIR_FROM_" ^ string_of_int i
+
+ type level + | VIR_ERR_NONE
+ | VIR_ERR_WARNING
+ | VIR_ERR_ERROR
+ | VIR_ERR_UNKNOWN_LEVEL of int
+
+ let string_of_level = function
+ | VIR_ERR_NONE -> "VIR_ERR_NONE"
+ | VIR_ERR_WARNING -> "VIR_ERR_WARNING"
+ | VIR_ERR_ERROR -> "VIR_ERR_ERROR"
+ | VIR_ERR_UNKNOWN_LEVEL i -> "VIR_ERR_LEVEL_" ^ string_of_int
i
+
+ type t = {
+ code : code;
+ domain : domain;
+ message : string option;
+ level : level;
+ str1 : string option;
+ str2 : string option;
+ str3 : string option;
+ int1 : int32;
+ int2 : int32;
+ }
+
+ let to_string { code = code; domain = domain; message = message } + let
buf = Buffer.create 128 in
+ Buffer.add_string buf "libvirt: ";
+ Buffer.add_string buf (string_of_code code);
+ Buffer.add_string buf ": ";
+ Buffer.add_string buf (string_of_domain domain);
+ Buffer.add_string buf ": ";
+ (match message with Some msg -> Buffer.add_string buf msg | None ->
());
+ Buffer.contents buf
+
+ external get_last_error : unit -> t option =
"ocaml_libvirt_virterror_get_last_error"
+ external get_last_conn_error : [>`R] Connect.t -> t option =
"ocaml_libvirt_virterror_get_last_conn_error"
+ external reset_last_error : unit -> unit =
"ocaml_libvirt_virterror_reset_last_error"
+ external reset_last_conn_error : [>`R] Connect.t -> unit =
"ocaml_libvirt_virterror_reset_last_conn_error"
+
+ let no_error () + { code = VIR_ERR_OK; domain = VIR_FROM_NONE;
+ message = None; level = VIR_ERR_NONE;
+ str1 = None; str2 = None; str3 = None;
+ int1 = 0_l; int2 = 0_l }
+end
+
+exception Virterror of Virterror.t
+exception Not_supported of string
+
+let rec map_ignore_errors f = function
+ | [] -> []
+ | x :: xs ->
+ try f x :: map_ignore_errors f xs
+ with Virterror _ -> map_ignore_errors f xs
+
+module Domain +struct
+ type 'rw t
+
+ type state + | InfoNoState | InfoRunning | InfoBlocked | InfoPaused
+ | InfoShutdown | InfoShutoff | InfoCrashed | InfoPMSuspended
+
+ type info = {
+ state : state;
+ max_mem : int64;
+ memory : int64;
+ nr_virt_cpu : int;
+ cpu_time : int64;
+ }
+
+ type vcpu_state = VcpuOffline | VcpuRunning | VcpuBlocked
+
+ type vcpu_info = {
+ number : int;
+ vcpu_state : vcpu_state;
+ vcpu_time : int64;
+ cpu : int;
+ }
+
+ type domain_create_flag + | START_PAUSED
+ | START_AUTODESTROY
+ | START_BYPASS_CACHE
+ | START_FORCE_BOOT
+ | START_VALIDATE
+ let rec int_of_domain_create_flags = function
+ | [] -> 0
+ | START_PAUSED :: flags -> 1 lor int_of_domain_create_flags flags
+ | START_AUTODESTROY :: flags -> 2 lor int_of_domain_create_flags flags
+ | START_BYPASS_CACHE :: flags -> 4 lor int_of_domain_create_flags flags
+ | START_FORCE_BOOT :: flags -> 8 lor int_of_domain_create_flags flags
+ | START_VALIDATE :: flags -> 16 lor int_of_domain_create_flags flags
+
+ type sched_param = string * sched_param_value
+ and sched_param_value + | SchedFieldInt32 of int32 | SchedFieldUInt32 of
int32
+ | SchedFieldInt64 of int64 | SchedFieldUInt64 of int64
+ | SchedFieldFloat of float | SchedFieldBool of bool
+
+ type typed_param = string * typed_param_value
+ and typed_param_value + | TypedFieldInt32 of int32 | TypedFieldUInt32 of
int32
+ | TypedFieldInt64 of int64 | TypedFieldUInt64 of int64
+ | TypedFieldFloat of float | TypedFieldBool of bool
+ | TypedFieldString of string
+
+ type migrate_flag = Live
+
+ type memory_flag = Virtual
+
+ type list_flag + | ListActive
+ | ListInactive
+ | ListAll
+
+ type block_stats = {
+ rd_req : int64;
+ rd_bytes : int64;
+ wr_req : int64;
+ wr_bytes : int64;
+ errs : int64;
+ }
+
+ type interface_stats = {
+ rx_bytes : int64;
+ rx_packets : int64;
+ rx_errs : int64;
+ rx_drop : int64;
+ tx_bytes : int64;
+ tx_packets : int64;
+ tx_errs : int64;
+ tx_drop : int64;
+ }
+
+ type get_all_domain_stats_flag + | GetAllDomainsStatsActive
+ | GetAllDomainsStatsInactive
+ | GetAllDomainsStatsOther
+ | GetAllDomainsStatsPaused
+ | GetAllDomainsStatsPersistent
+ | GetAllDomainsStatsRunning
+ | GetAllDomainsStatsShutoff
+ | GetAllDomainsStatsTransient
+ | GetAllDomainsStatsBacking
+ | GetAllDomainsStatsEnforceStats
+
+ type stats_type + | StatsState | StatsCpuTotal | StatsBalloon | StatsVcpu
+ | StatsInterface | StatsBlock | StatsPerf
+
+ type domain_stats_record = {
+ dom_uuid : uuid;
+ params : typed_param array;
+ }
+
+ type xml_desc_flag + | XmlSecure
+ | XmlInactive
+ | XmlUpdateCPU
+ | XmlMigratable
+
+ (* The maximum size for Domain.memory_peek and Domain.block_peek
+ * supported by libvirt. This may change with different versions
+ * of libvirt in the future, hence it's a function.
+ *)
+ let max_peek _ = 65536
+
+ external create_linux : [>`W] Connect.t -> xml -> rw t =
"ocaml_libvirt_domain_create_linux"
+ external _create_xml : [>`W] Connect.t -> xml -> int -> rw t =
"ocaml_libvirt_domain_create_xml"
+ let create_xml conn xml flags + _create_xml conn xml
(int_of_domain_create_flags flags)
+ external lookup_by_id : 'a Connect.t -> int -> 'a t =
"ocaml_libvirt_domain_lookup_by_id"
+ external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t =
"ocaml_libvirt_domain_lookup_by_uuid"
+ external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t
= "ocaml_libvirt_domain_lookup_by_uuid_string"
+ external lookup_by_name : 'a Connect.t -> string -> 'a t =
"ocaml_libvirt_domain_lookup_by_name"
+ external destroy : [>`W] t -> unit =
"ocaml_libvirt_domain_destroy"
+ external free : [>`R] t -> unit = "ocaml_libvirt_domain_free"
+ external suspend : [>`W] t -> unit =
"ocaml_libvirt_domain_suspend"
+ external resume : [>`W] t -> unit =
"ocaml_libvirt_domain_resume"
+ external save : [>`W] t -> filename -> unit =
"ocaml_libvirt_domain_save"
+ external restore : [>`W] Connect.t -> filename -> unit =
"ocaml_libvirt_domain_restore"
+ external core_dump : [>`W] t -> filename -> unit =
"ocaml_libvirt_domain_core_dump"
+ external shutdown : [>`W] t -> unit =
"ocaml_libvirt_domain_shutdown"
+ external reboot : [>`W] t -> unit =
"ocaml_libvirt_domain_reboot"
+ external get_name : [>`R] t -> string =
"ocaml_libvirt_domain_get_name"
+ external get_uuid : [>`R] t -> uuid =
"ocaml_libvirt_domain_get_uuid"
+ external get_uuid_string : [>`R] t -> string =
"ocaml_libvirt_domain_get_uuid_string"
+ external get_id : [>`R] t -> int =
"ocaml_libvirt_domain_get_id"
+ external get_os_type : [>`R] t -> string =
"ocaml_libvirt_domain_get_os_type"
+ external get_max_memory : [>`R] t -> int64 =
"ocaml_libvirt_domain_get_max_memory"
+ external set_max_memory : [>`W] t -> int64 -> unit =
"ocaml_libvirt_domain_set_max_memory"
+ external set_memory : [>`W] t -> int64 -> unit =
"ocaml_libvirt_domain_set_memory"
+ external get_info : [>`R] t -> info =
"ocaml_libvirt_domain_get_info"
+ external get_xml_desc : [>`R] t -> xml =
"ocaml_libvirt_domain_get_xml_desc"
+ external get_xml_desc_flags : [>`W] t -> xml_desc_flag list -> xml =
"ocaml_libvirt_domain_get_xml_desc_flags"
+ external get_scheduler_type : [>`R] t -> string * int =
"ocaml_libvirt_domain_get_scheduler_type"
+ external get_scheduler_parameters : [>`R] t -> int -> sched_param
array = "ocaml_libvirt_domain_get_scheduler_parameters"
+ external set_scheduler_parameters : [>`W] t -> sched_param array ->
unit = "ocaml_libvirt_domain_set_scheduler_parameters"
+ external define_xml : [>`W] Connect.t -> xml -> rw t =
"ocaml_libvirt_domain_define_xml"
+ external undefine : [>`W] t -> unit =
"ocaml_libvirt_domain_undefine"
+ external create : [>`W] t -> unit =
"ocaml_libvirt_domain_create"
+ external get_autostart : [>`R] t -> bool =
"ocaml_libvirt_domain_get_autostart"
+ external set_autostart : [>`W] t -> bool -> unit =
"ocaml_libvirt_domain_set_autostart"
+ external set_vcpus : [>`W] t -> int -> unit =
"ocaml_libvirt_domain_set_vcpus"
+ external pin_vcpu : [>`W] t -> int -> string -> unit =
"ocaml_libvirt_domain_pin_vcpu"
+ external get_vcpus : [>`R] t -> int -> int -> int * vcpu_info
array * string = "ocaml_libvirt_domain_get_vcpus"
+ external get_cpu_stats : [>`R] t -> typed_param list array =
"ocaml_libvirt_domain_get_cpu_stats"
+ external get_max_vcpus : [>`R] t -> int =
"ocaml_libvirt_domain_get_max_vcpus"
+ external attach_device : [>`W] t -> xml -> unit =
"ocaml_libvirt_domain_attach_device"
+ external detach_device : [>`W] t -> xml -> unit =
"ocaml_libvirt_domain_detach_device"
+ external migrate : [>`W] t -> [>`W] Connect.t -> migrate_flag
list -> ?dname:string -> ?uri:string -> ?bandwidth:int -> unit ->
rw t = "ocaml_libvirt_domain_migrate_bytecode"
"ocaml_libvirt_domain_migrate_native"
+ external block_stats : [>`R] t -> string -> block_stats =
"ocaml_libvirt_domain_block_stats"
+ external interface_stats : [>`R] t -> string -> interface_stats =
"ocaml_libvirt_domain_interface_stats"
+ external block_peek : [>`W] t -> string -> int64 -> int ->
string -> int -> unit =
"ocaml_libvirt_domain_block_peek_bytecode"
"ocaml_libvirt_domain_block_peek_native"
+ external memory_peek : [>`W] t -> memory_flag list -> int64 ->
int -> string -> int -> unit =
"ocaml_libvirt_domain_memory_peek_bytecode"
"ocaml_libvirt_domain_memory_peek_native"
+
+ external get_all_domain_stats : [>`R] Connect.t -> stats_type list
-> get_all_domain_stats_flag list -> domain_stats_record array =
"ocaml_libvirt_domain_get_all_domain_stats"
+
+ external const : [>`R] t -> ro t = "%identity"
+
+ let get_domains conn flags + (* Old/slow/inefficient method. *)
+ let get_active, get_inactive + if List.mem ListAll flags then
+ (true, true)
+ else
+ (List.mem ListActive flags, List.mem ListInactive flags) in
+ let active_doms + if get_active then (
+ let n = Connect.num_of_domains conn in
+ let ids = Connect.list_domains conn n in
+ let ids = Array.to_list ids in
+ map_ignore_errors (lookup_by_id conn) ids
+ ) else [] in
+
+ let inactive_doms + if get_inactive then (
+ let n = Connect.num_of_defined_domains conn in
+ let names = Connect.list_defined_domains conn n in
+ let names = Array.to_list names in
+ map_ignore_errors (lookup_by_name conn) names
+ ) else [] in
+
+ active_doms @ inactive_doms
+
+ let get_domains_and_infos conn flags + (* Old/slow/inefficient method. *)
+ let get_active, get_inactive + if List.mem ListAll flags then
+ (true, true)
+ else (List.mem ListActive flags, List.mem ListInactive flags) in
+ let active_doms + if get_active then (
+ let n = Connect.num_of_domains conn in
+ let ids = Connect.list_domains conn n in
+ let ids = Array.to_list ids in
+ map_ignore_errors (lookup_by_id conn) ids
+ ) else [] in
+
+ let inactive_doms + if get_inactive then (
+ let n = Connect.num_of_defined_domains conn in
+ let names = Connect.list_defined_domains conn n in
+ let names = Array.to_list names in
+ map_ignore_errors (lookup_by_name conn) names
+ ) else [] in
+
+ let doms = active_doms @ inactive_doms in
+
+ map_ignore_errors (fun dom -> (dom, get_info dom)) doms
+end
+
+module Event +struct
+
+ module Defined = struct
+ type t = [
+ | `Added
+ | `Updated
+ | `Unknown of int
+ ]
+
+ let to_string = function
+ | `Added -> "Added"
+ | `Updated -> "Updated"
+ | `Unknown x -> Printf.sprintf "Unknown Defined.detail: %d"
x
+
+ let make = function
+ | 0 -> `Added
+ | 1 -> `Updated
+ | x -> `Unknown x (* newer libvirt *)
+ end
+
+ module Undefined = struct
+ type t = [
+ | `Removed
+ | `Unknown of int
+ ]
+
+ let to_string = function
+ | `Removed -> "UndefinedRemoved"
+ | `Unknown x -> Printf.sprintf "Unknown Undefined.detail:
%d" x
+
+ let make = function
+ | 0 -> `Removed
+ | x -> `Unknown x (* newer libvirt *)
+ end
+
+ module Started = struct
+ type t = [
+ | `Booted
+ | `Migrated
+ | `Restored
+ | `FromSnapshot
+ | `Wakeup
+ | `Unknown of int
+ ]
+
+ let to_string = function
+ | `Booted -> "Booted"
+ | `Migrated -> "Migrated"
+ | `Restored -> "Restored"
+ | `FromSnapshot -> "FromSnapshot"
+ | `Wakeup -> "Wakeup"
+ | `Unknown x -> Printf.sprintf "Unknown Started.detail: %d"
x
+
+ let make = function
+ | 0 -> `Booted
+ | 1 -> `Migrated
+ | 2 -> `Restored
+ | 3 -> `FromSnapshot
+ | 4 -> `Wakeup
+ | x -> `Unknown x (* newer libvirt *)
+ end
+
+ module Suspended = struct
+ type t = [
+ | `Paused
+ | `Migrated
+ | `IOError
+ | `Watchdog
+ | `Restored
+ | `FromSnapshot
+ | `APIError
+ | `Unknown of int (* newer libvirt *)
+ ]
+
+ let to_string = function
+ | `Paused -> "Paused"
+ | `Migrated -> "Migrated"
+ | `IOError -> "IOError"
+ | `Watchdog -> "Watchdog"
+ | `Restored -> "Restored"
+ | `FromSnapshot -> "FromSnapshot"
+ | `APIError -> "APIError"
+ | `Unknown x -> Printf.sprintf "Unknown Suspended.detail:
%d" x
+
+ let make = function
+ | 0 -> `Paused
+ | 1 -> `Migrated
+ | 2 -> `IOError
+ | 3 -> `Watchdog
+ | 4 -> `Restored
+ | 5 -> `FromSnapshot
+ | 6 -> `APIError
+ | x -> `Unknown x (* newer libvirt *)
+ end
+
+ module Resumed = struct
+ type t = [
+ | `Unpaused
+ | `Migrated
+ | `FromSnapshot
+ | `Unknown of int (* newer libvirt *)
+ ]
+
+ let to_string = function
+ | `Unpaused -> "Unpaused"
+ | `Migrated -> "Migrated"
+ | `FromSnapshot -> "FromSnapshot"
+ | `Unknown x -> Printf.sprintf "Unknown Resumed.detail: %d"
x
+
+ let make = function
+ | 0 -> `Unpaused
+ | 1 -> `Migrated
+ | 2 -> `FromSnapshot
+ | x -> `Unknown x (* newer libvirt *)
+ end
+
+ module Stopped = struct
+ type t = [
+ | `Shutdown
+ | `Destroyed
+ | `Crashed
+ | `Migrated
+ | `Saved
+ | `Failed
+ | `FromSnapshot
+ | `Unknown of int
+ ]
+ let to_string = function
+ | `Shutdown -> "Shutdown"
+ | `Destroyed -> "Destroyed"
+ | `Crashed -> "Crashed"
+ | `Migrated -> "Migrated"
+ | `Saved -> "Saved"
+ | `Failed -> "Failed"
+ | `FromSnapshot -> "FromSnapshot"
+ | `Unknown x -> Printf.sprintf "Unknown Stopped.detail: %d"
x
+
+ let make = function
+ | 0 -> `Shutdown
+ | 1 -> `Destroyed
+ | 2 -> `Crashed
+ | 3 -> `Migrated
+ | 4 -> `Saved
+ | 5 -> `Failed
+ | 6 -> `FromSnapshot
+ | x -> `Unknown x (* newer libvirt *)
+ end
+
+ module PM_suspended = struct
+ type t = [
+ | `Memory
+ | `Disk
+ | `Unknown of int (* newer libvirt *)
+ ]
+
+ let to_string = function
+ | `Memory -> "Memory"
+ | `Disk -> "Disk"
+ | `Unknown x -> Printf.sprintf "Unknown PM_suspended.detail:
%d" x
+
+ let make = function
+ | 0 -> `Memory
+ | 1 -> `Disk
+ | x -> `Unknown x (* newer libvirt *)
+ end
+
+ let string_option x = match x with
+ | None -> "None"
+ | Some x' -> "Some " ^ x'
+
+ module Lifecycle = struct
+ type t = [
+ | `Defined of Defined.t
+ | `Undefined of Undefined.t
+ | `Started of Started.t
+ | `Suspended of Suspended.t
+ | `Resumed of Resumed.t
+ | `Stopped of Stopped.t
+ | `Shutdown (* no detail defined yet *)
+ | `PMSuspended of PM_suspended.t
+ | `Unknown of int (* newer libvirt *)
+ ]
+
+ let to_string = function
+ | `Defined x -> "Defined " ^ (Defined.to_string x)
+ | `Undefined x -> "Undefined " ^ (Undefined.to_string x)
+ | `Started x -> "Started " ^ (Started.to_string x)
+ | `Suspended x -> "Suspended " ^ (Suspended.to_string x)
+ | `Resumed x -> "Resumed " ^ (Resumed.to_string x)
+ | `Stopped x -> "Stopped " ^ (Stopped.to_string x)
+ | `Shutdown -> "Shutdown"
+ | `PMSuspended x -> "PMSuspended " ^ (PM_suspended.to_string
x)
+ | `Unknown x -> Printf.sprintf "Unknown Lifecycle event: %d"
x
+
+ let make (ty, detail) = match ty with
+ | 0 -> `Defined (Defined.make detail)
+ | 1 -> `Undefined (Undefined.make detail)
+ | 2 -> `Started (Started.make detail)
+ | 3 -> `Suspended (Suspended.make detail)
+ | 4 -> `Resumed (Resumed.make detail)
+ | 5 -> `Stopped (Stopped.make detail)
+ | 6 -> `Shutdown
+ | 7 -> `PMSuspended (PM_suspended.make detail)
+ | x -> `Unknown x
+ end
+
+ module Reboot = struct
+ type t = unit
+
+ let to_string _ = "()"
+
+ let make () = ()
+ end
+
+ module Rtc_change = struct
+ type t = int64
+
+ let to_string = Int64.to_string
+
+ let make x = x
+ end
+
+ module Watchdog = struct
+ type t = [
+ | `None
+ | `Pause
+ | `Reset
+ | `Poweroff
+ | `Shutdown
+ | `Debug
+ | `Unknown of int
+ ]
+
+ let to_string = function
+ | `None -> "None"
+ | `Pause -> "Pause"
+ | `Reset -> "Reset"
+ | `Poweroff -> "Poweroff"
+ | `Shutdown -> "Shutdown"
+ | `Debug -> "Debug"
+ | `Unknown x -> Printf.sprintf "Unknown watchdog_action: %d"
x
+
+ let make = function
+ | 0 -> `None
+ | 1 -> `Pause
+ | 2 -> `Reset
+ | 3 -> `Poweroff
+ | 4 -> `Shutdown
+ | 5 -> `Debug
+ | x -> `Unknown x (* newer libvirt *)
+ end
+
+ module Io_error = struct
+ type action = [
+ | `None
+ | `Pause
+ | `Report
+ | `Unknown of int (* newer libvirt *)
+ ]
+
+ let string_of_action = function
+ | `None -> "None"
+ | `Pause -> "Pause"
+ | `Report -> "Report"
+ | `Unknown x -> Printf.sprintf "Unknown Io_error.action: %d"
x
+
+ let action_of_int = function
+ | 0 -> `None
+ | 1 -> `Pause
+ | 2 -> `Report
+ | x -> `Unknown x
+
+ type t = {
+ src_path: string option;
+ dev_alias: string option;
+ action: action;
+ reason: string option;
+ }
+
+ let to_string t = Printf.sprintf
+ "{ Io_error.src_path = %s; dev_alias = %s; action = %s; reason =
%s }"
+ (string_option t.src_path)
+ (string_option t.dev_alias)
+ (string_of_action t.action)
+ (string_option t.reason)
+
+ let make (src_path, dev_alias, action, reason) = {
+ src_path = src_path;
+ dev_alias = dev_alias;
+ action = action_of_int action;
+ reason = reason;
+ }
+
+ let make_noreason (src_path, dev_alias, action) + make (src_path,
dev_alias, action, None)
+ end
+
+ module Graphics_address = struct
+ type family = [
+ | `Ipv4
+ | `Ipv6
+ | `Unix
+ | `Unknown of int (* newer libvirt *)
+ ]
+
+ let string_of_family = function
+ | `Ipv4 -> "IPv4"
+ | `Ipv6 -> "IPv6"
+ | `Unix -> "UNIX"
+ | `Unknown x -> Printf.sprintf "Unknown Graphics_address.family:
%d" x
+
+ let family_of_int = function
+ (* no zero *)
+ | 1 -> `Ipv4
+ | 2 -> `Ipv6
+ | 3 -> `Unix
+ | x -> `Unknown x
+
+ type t = {
+ family: family; (** Address family *)
+ node: string option; (** Address of node (eg IP address, or UNIX path
*)
+ service: string option; (** Service name/number (eg TCP port, or NULL) *)
+ }
+
+ let to_string t = Printf.sprintf
+ "{ family = %s; node = %s; service = %s }"
+ (string_of_family t.family)
+ (string_option t.node)
+ (string_option t.service)
+
+ let make (family, node, service) = {
+ family = family_of_int family;
+ node = node;
+ service = service;
+ }
+ end
+
+ module Graphics_subject = struct
+ type identity = {
+ ty: string option;
+ name: string option;
+ }
+
+ let string_of_identity t = Printf.sprintf
+ "{ ty = %s; name = %s }"
+ (string_option t.ty)
+ (string_option t.name)
+
+ type t = identity list
+
+ let to_string ts + "[ " ^ (String.concat "; "
(List.map string_of_identity ts)) ^ " ]"
+
+ let make xs + List.map (fun (ty, name) -> { ty = ty; name = name })
+ (Array.to_list xs)
+ end
+
+ module Graphics = struct
+ type phase = [
+ | `Connect
+ | `Initialize
+ | `Disconnect
+ | `Unknown of int (** newer libvirt *)
+ ]
+
+ let string_of_phase = function
+ | `Connect -> "Connect"
+ | `Initialize -> "Initialize"
+ | `Disconnect -> "Disconnect"
+ | `Unknown x -> Printf.sprintf "Unknown Graphics.phase: %d"
x
+
+ let phase_of_int = function
+ | 0 -> `Connect
+ | 1 -> `Initialize
+ | 2 -> `Disconnect
+ | x -> `Unknown x
+
+ type t = {
+ phase: phase; (** the phase of the connection *)
+ local: Graphics_address.t; (** the local server address *)
+ remote: Graphics_address.t; (** the remote client address *)
+ auth_scheme: string option; (** the authentication scheme activated *)
+ subject: Graphics_subject.t; (** the authenticated subject (user) *)
+ }
+
+ let to_string t + let phase = Printf.sprintf "phase = %s"
+ (string_of_phase t.phase) in
+ let local = Printf.sprintf "local = %s"
+ (Graphics_address.to_string t.local) in
+ let remote = Printf.sprintf "remote = %s"
+ (Graphics_address.to_string t.remote) in
+ let auth_scheme = Printf.sprintf "auth_scheme = %s"
+ (string_option t.auth_scheme) in
+ let subject = Printf.sprintf "subject = %s"
+ (Graphics_subject.to_string t.subject) in
+ "{ " ^ (String.concat "; " [ phase; local; remote;
auth_scheme; subject ]) ^ " }"
+
+ let make (phase, local, remote, auth_scheme, subject) = {
+ phase = phase_of_int phase;
+ local = Graphics_address.make local;
+ remote = Graphics_address.make remote;
+ auth_scheme = auth_scheme;
+ subject = Graphics_subject.make subject;
+ }
+ end
+
+ module Control_error = struct
+ type t = unit
+
+ let to_string () = "()"
+
+ let make () = ()
+ end
+
+ module Block_job = struct
+ type ty = [
+ | `KnownUnknown (* explicitly named UNKNOWN in the spec *)
+ | `Pull
+ | `Copy
+ | `Commit
+ | `Unknown of int (* newer libvirt *)
+ ]
+
+ let string_of_ty = function
+ | `KnownUnknown -> "KnownUnknown"
+ | `Pull -> "Pull"
+ | `Copy -> "Copy"
+ | `Commit -> "Commit"
+ | `Unknown x -> Printf.sprintf "Unknown Block_job.ty: %d" x
+
+ let ty_of_int = function
+ | 0 -> `KnownUnknown
+ | 1 -> `Pull
+ | 2 -> `Copy
+ | 3 -> `Commit
+ | x -> `Unknown x (* newer libvirt *)
+
+ type status = [
+ | `Completed
+ | `Failed
+ | `Cancelled
+ | `Ready
+ | `Unknown of int
+ ]
+
+ let string_of_status = function
+ | `Completed -> "Completed"
+ | `Failed -> "Failed"
+ | `Cancelled -> "Cancelled"
+ | `Ready -> "Ready"
+ | `Unknown x -> Printf.sprintf "Unknown Block_job.status:
%d" x
+
+ let status_of_int = function
+ | 0 -> `Completed
+ | 1 -> `Failed
+ | 2 -> `Cancelled
+ | 3 -> `Ready
+ | x -> `Unknown x
+
+ type t = {
+ disk: string option;
+ ty: ty;
+ status: status;
+ }
+
+ let to_string t = Printf.sprintf "{ disk = %s; ty = %s; status = %s
}"
+ (string_option t.disk)
+ (string_of_ty t.ty)
+ (string_of_status t.status)
+
+ let make (disk, ty, status) = {
+ disk = disk;
+ ty = ty_of_int ty;
+ status = status_of_int ty;
+ }
+ end
+
+ module Disk_change = struct
+ type reason = [
+ | `MissingOnStart
+ | `Unknown of int
+ ]
+
+ let string_of_reason = function
+ | `MissingOnStart -> "MissingOnStart"
+ | `Unknown x -> Printf.sprintf "Unknown Disk_change.reason:
%d" x
+
+ let reason_of_int = function
+ | 0 -> `MissingOnStart
+ | x -> `Unknown x
+
+ type t = {
+ old_src_path: string option;
+ new_src_path: string option;
+ dev_alias: string option;
+ reason: reason;
+ }
+
+ let to_string t + let o = Printf.sprintf "old_src_path = %s"
(string_option t.old_src_path) in
+ let n = Printf.sprintf "new_src_path = %s" (string_option
t.new_src_path) in
+ let d = Printf.sprintf "dev_alias = %s" (string_option
t.dev_alias) in
+ let r = string_of_reason t.reason in
+ "{ " ^ (String.concat "; " [ o; n; d; r ]) ^ "
}"
+
+ let make (o, n, d, r) = {
+ old_src_path = o;
+ new_src_path = n;
+ dev_alias = d;
+ reason = reason_of_int r;
+ }
+ end
+
+ module Tray_change = struct
+ type reason = [
+ | `Open
+ | `Close
+ | `Unknown of int
+ ]
+
+ let string_of_reason = function
+ | `Open -> "Open"
+ | `Close -> "Close"
+ | `Unknown x -> Printf.sprintf "Unknown Tray_change.reason:
%d" x
+
+ let reason_of_int = function
+ | 0 -> `Open
+ | 1 -> `Close
+ | x -> `Unknown x
+
+ type t = {
+ dev_alias: string option;
+ reason: reason;
+ }
+
+ let to_string t = Printf.sprintf
+ "{ dev_alias = %s; reason = %s }"
+ (string_option t.dev_alias)
+ (string_of_reason t.reason)
+
+ let make (dev_alias, reason) = {
+ dev_alias = dev_alias;
+ reason = reason_of_int reason;
+ }
+ end
+
+ module PM_wakeup = struct
+ type reason = [
+ | `Unknown of int
+ ]
+
+ type t = reason
+
+ let to_string = function
+ | `Unknown x -> Printf.sprintf "Unknown PM_wakeup.reason:
%d" x
+
+ let make x = `Unknown x
+ end
+
+ module PM_suspend = struct
+ type reason = [
+ | `Unknown of int
+ ]
+
+ type t = reason
+
+ let to_string = function
+ | `Unknown x -> Printf.sprintf "Unknown PM_suspend.reason:
%d" x
+
+ let make x = `Unknown x
+ end
+
+ module Balloon_change = struct
+ type t = int64
+
+ let to_string = Int64.to_string
+ let make x = x
+ end
+
+ module PM_suspend_disk = struct
+ type reason = [
+ | `Unknown of int
+ ]
+
+ type t = reason
+
+ let to_string = function
+ | `Unknown x -> Printf.sprintf "Unknown PM_suspend_disk.reason:
%d" x
+
+ let make x = `Unknown x
+ end
+
+ type callback + | Lifecycle of ([`R] Domain.t -> Lifecycle.t ->
unit)
+ | Reboot of ([`R] Domain.t -> Reboot.t -> unit)
+ | RtcChange of ([`R] Domain.t -> Rtc_change.t -> unit)
+ | Watchdog of ([`R] Domain.t -> Watchdog.t -> unit)
+ | IOError of ([`R] Domain.t -> Io_error.t -> unit)
+ | Graphics of ([`R] Domain.t -> Graphics.t -> unit)
+ | IOErrorReason of ([`R] Domain.t -> Io_error.t -> unit)
+ | ControlError of ([`R] Domain.t -> Control_error.t -> unit)
+ | BlockJob of ([`R] Domain.t -> Block_job.t -> unit)
+ | DiskChange of ([`R] Domain.t -> Disk_change.t -> unit)
+ | TrayChange of ([`R] Domain.t -> Tray_change.t -> unit)
+ | PMWakeUp of ([`R] Domain.t -> PM_wakeup.t -> unit)
+ | PMSuspend of ([`R] Domain.t -> PM_suspend.t -> unit)
+ | BalloonChange of ([`R] Domain.t -> Balloon_change.t -> unit)
+ | PMSuspendDisk of ([`R] Domain.t -> PM_suspend_disk.t -> unit)
+
+ type callback_id = int64
+
+ let fresh_callback_id + let next = ref 0L in
+ fun () ->
+ let result = !next in
+ next := Int64.succ !next;
+ result
+
+ let make_table value_name + let table = Hashtbl.create 16 in
+ let callback callback_id generic x + if Hashtbl.mem table callback_id
+ then Hashtbl.find table callback_id generic x in
+ let _ = Callback.register value_name callback in
+ table
+
+ let u_table = make_table "Libvirt.u_callback"
+ let i_table = make_table "Libvirt.i_callback"
+ let i64_table = make_table "Libvirt.i64_callback"
+ let i_i_table = make_table "Libvirt.i_i_callback"
+ let s_i_table = make_table "Libvirt.s_i_callback"
+ let s_i_i_table = make_table "Libvirt.s_i_i_callback"
+ let s_s_i_table = make_table "Libvirt.s_s_i_callback"
+ let s_s_i_s_table = make_table "Libvirt.s_s_i_s_callback"
+ let s_s_s_i_table = make_table "Libvirt.s_s_s_i_callback"
+ let i_ga_ga_s_gs_table = make_table "Libvirt.i_ga_ga_s_gs_callback"
+
+ external register_default_impl : unit -> unit =
"ocaml_libvirt_event_register_default_impl"
+
+ external run_default_impl : unit -> unit =
"ocaml_libvirt_event_run_default_impl"
+
+ external register_any' : 'a Connect.t -> 'a Domain.t option
-> callback -> callback_id -> int =
"ocaml_libvirt_connect_domain_event_register_any"
+
+ external deregister_any' : 'a Connect.t -> int -> unit =
"ocaml_libvirt_connect_domain_event_deregister_any"
+
+ let our_id_to_libvirt_id = Hashtbl.create 16
+
+ let register_any conn ?dom callback + let id = fresh_callback_id () in
+ begin match callback with
+ | Lifecycle f ->
+ Hashtbl.add i_i_table id (fun dom x ->
+ f dom (Lifecycle.make x)
+ )
+ | Reboot f ->
+ Hashtbl.add u_table id (fun dom x ->
+ f dom (Reboot.make x)
+ )
+ | RtcChange f ->
+ Hashtbl.add i64_table id (fun dom x ->
+ f dom (Rtc_change.make x)
+ )
+ | Watchdog f ->
+ Hashtbl.add i_table id (fun dom x ->
+ f dom (Watchdog.make x)
+ )
+ | IOError f ->
+ Hashtbl.add s_s_i_table id (fun dom x ->
+ f dom (Io_error.make_noreason x)
+ )
+ | Graphics f ->
+ Hashtbl.add i_ga_ga_s_gs_table id (fun dom x ->
+ f dom (Graphics.make x)
+ )
+ | IOErrorReason f ->
+ Hashtbl.add s_s_i_s_table id (fun dom x ->
+ f dom (Io_error.make x)
+ )
+ | ControlError f ->
+ Hashtbl.add u_table id (fun dom x ->
+ f dom (Control_error.make x)
+ )
+ | BlockJob f ->
+ Hashtbl.add s_i_i_table id (fun dom x ->
+ f dom (Block_job.make x)
+ )
+ | DiskChange f ->
+ Hashtbl.add s_s_s_i_table id (fun dom x ->
+ f dom (Disk_change.make x)
+ )
+ | TrayChange f ->
+ Hashtbl.add s_i_table id (fun dom x ->
+ f dom (Tray_change.make x)
+ )
+ | PMWakeUp f ->
+ Hashtbl.add i_table id (fun dom x ->
+ f dom (PM_wakeup.make x)
+ )
+ | PMSuspend f ->
+ Hashtbl.add i_table id (fun dom x ->
+ f dom (PM_suspend.make x)
+ )
+ | BalloonChange f ->
+ Hashtbl.add i64_table id (fun dom x ->
+ f dom (Balloon_change.make x)
+ )
+ | PMSuspendDisk f ->
+ Hashtbl.add i_table id (fun dom x ->
+ f dom (PM_suspend_disk.make x)
+ )
+ end;
+ let libvirt_id = register_any' conn dom callback id in
+ Hashtbl.replace our_id_to_libvirt_id id libvirt_id;
+ id
+
+ let deregister_any conn id + if Hashtbl.mem our_id_to_libvirt_id id then
begin
+ let libvirt_id = Hashtbl.find our_id_to_libvirt_id id in
+ deregister_any' conn libvirt_id
+ end;
+ Hashtbl.remove our_id_to_libvirt_id id;
+ Hashtbl.remove u_table id;
+ Hashtbl.remove i_table id;
+ Hashtbl.remove i64_table id;
+ Hashtbl.remove i_i_table id;
+ Hashtbl.remove s_i_table id;
+ Hashtbl.remove s_i_i_table id;
+ Hashtbl.remove s_s_i_table id;
+ Hashtbl.remove s_s_i_s_table id;
+ Hashtbl.remove s_s_s_i_table id;
+ Hashtbl.remove i_ga_ga_s_gs_table id
+
+ let timeout_table = Hashtbl.create 16
+ let _ + let callback x + if Hashtbl.mem timeout_table x
+ then Hashtbl.find timeout_table x () in
+ Callback.register "Libvirt.timeout_callback" callback
+
+ type timer_id = int64
+
+ external add_timeout' : 'a Connect.t -> int -> int64 -> int
= "ocaml_libvirt_event_add_timeout"
+
+ external remove_timeout' : 'a Connect.t -> int -> unit =
"ocaml_libvirt_event_remove_timeout"
+
+ let our_id_to_timer_id = Hashtbl.create 16
+ let add_timeout conn ms fn + let id = fresh_callback_id () in
+ Hashtbl.add timeout_table id fn;
+ let timer_id = add_timeout' conn ms id in
+ Hashtbl.add our_id_to_timer_id id timer_id;
+ id
+
+ let remove_timeout conn id + if Hashtbl.mem our_id_to_timer_id id then
begin
+ let timer_id = Hashtbl.find our_id_to_timer_id id in
+ remove_timeout' conn timer_id
+ end;
+ Hashtbl.remove our_id_to_timer_id id;
+ Hashtbl.remove timeout_table id
+end
+
+module Network +struct
+ type 'rw t
+
+ external lookup_by_name : 'a Connect.t -> string -> 'a t =
"ocaml_libvirt_network_lookup_by_name"
+ external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t =
"ocaml_libvirt_network_lookup_by_uuid"
+ external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t
= "ocaml_libvirt_network_lookup_by_uuid_string"
+ external create_xml : [>`W] Connect.t -> xml -> rw t =
"ocaml_libvirt_network_create_xml"
+ external define_xml : [>`W] Connect.t -> xml -> rw t =
"ocaml_libvirt_network_define_xml"
+ external undefine : [>`W] t -> unit =
"ocaml_libvirt_network_undefine"
+ external create : [>`W] t -> unit =
"ocaml_libvirt_network_create"
+ external destroy : [>`W] t -> unit =
"ocaml_libvirt_network_destroy"
+ external free : [>`R] t -> unit =
"ocaml_libvirt_network_free"
+ external get_name : [>`R] t -> string =
"ocaml_libvirt_network_get_name"
+ external get_uuid : [>`R] t -> uuid =
"ocaml_libvirt_network_get_uuid"
+ external get_uuid_string : [>`R] t -> string =
"ocaml_libvirt_network_get_uuid_string"
+ external get_xml_desc : [>`R] t -> xml =
"ocaml_libvirt_network_get_xml_desc"
+ external get_bridge_name : [>`R] t -> string =
"ocaml_libvirt_network_get_bridge_name"
+ external get_autostart : [>`R] t -> bool =
"ocaml_libvirt_network_get_autostart"
+ external set_autostart : [>`W] t -> bool -> unit =
"ocaml_libvirt_network_set_autostart"
+
+ external const : [>`R] t -> ro t = "%identity"
+end
+
+module Pool +struct
+ type 'rw t
+ type pool_state = Inactive | Building | Running | Degraded | Inaccessible
+ type pool_build_flags = New | Repair | Resize
+ type pool_delete_flags = Normal | Zeroed
+ type pool_info = {
+ state : pool_state;
+ capacity : int64;
+ allocation : int64;
+ available : int64;
+ }
+
+ external lookup_by_name : 'a Connect.t -> string -> 'a t =
"ocaml_libvirt_storage_pool_lookup_by_name"
+ external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t =
"ocaml_libvirt_storage_pool_lookup_by_uuid"
+ external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t
= "ocaml_libvirt_storage_pool_lookup_by_uuid_string"
+ external create_xml : [>`W] Connect.t -> xml -> rw t =
"ocaml_libvirt_storage_pool_create_xml"
+ external define_xml : [>`W] Connect.t -> xml -> rw t =
"ocaml_libvirt_storage_pool_define_xml"
+ external build : [>`W] t -> pool_build_flags -> unit =
"ocaml_libvirt_storage_pool_build"
+ external undefine : [>`W] t -> unit =
"ocaml_libvirt_storage_pool_undefine"
+ external create : [>`W] t -> unit =
"ocaml_libvirt_storage_pool_create"
+ external destroy : [>`W] t -> unit =
"ocaml_libvirt_storage_pool_destroy"
+ external delete : [>`W] t -> unit =
"ocaml_libvirt_storage_pool_delete"
+ external free : [>`R] t -> unit =
"ocaml_libvirt_storage_pool_free"
+ external refresh : [`R] t -> unit =
"ocaml_libvirt_storage_pool_refresh"
+ external get_name : [`R] t -> string =
"ocaml_libvirt_storage_pool_get_name"
+ external get_uuid : [`R] t -> uuid =
"ocaml_libvirt_storage_pool_get_uuid"
+ external get_uuid_string : [`R] t -> string =
"ocaml_libvirt_storage_pool_get_uuid_string"
+ external get_info : [`R] t -> pool_info =
"ocaml_libvirt_storage_pool_get_info"
+ external get_xml_desc : [`R] t -> xml =
"ocaml_libvirt_storage_pool_get_xml_desc"
+ external get_autostart : [`R] t -> bool =
"ocaml_libvirt_storage_pool_get_autostart"
+ external set_autostart : [>`W] t -> bool -> unit =
"ocaml_libvirt_storage_pool_set_autostart"
+ external num_of_volumes : [`R] t -> int =
"ocaml_libvirt_storage_pool_num_of_volumes"
+ external list_volumes : [`R] t -> int -> string array =
"ocaml_libvirt_storage_pool_list_volumes"
+ external const : [>`R] t -> ro t = "%identity"
+end
+
+module Volume +struct
+ type 'rw t
+ type vol_type = File | Block | Dir | Network | NetDir | Ploop
+ type vol_delete_flags = Normal | Zeroed
+ type vol_info = {
+ typ : vol_type;
+ capacity : int64;
+ allocation : int64;
+ }
+
+ external lookup_by_name : 'a Pool.t -> string -> 'a t =
"ocaml_libvirt_storage_vol_lookup_by_name"
+ external lookup_by_key : 'a Connect.t -> string -> 'a t =
"ocaml_libvirt_storage_vol_lookup_by_key"
+ external lookup_by_path : 'a Connect.t -> string -> 'a t =
"ocaml_libvirt_storage_vol_lookup_by_path"
+ external pool_of_volume : 'a t -> 'a Pool.t =
"ocaml_libvirt_storage_pool_lookup_by_volume"
+ external get_name : [`R] t -> string =
"ocaml_libvirt_storage_vol_get_name"
+ external get_key : [`R] t -> string =
"ocaml_libvirt_storage_vol_get_key"
+ external get_path : [`R] t -> string =
"ocaml_libvirt_storage_vol_get_path"
+ external get_info : [`R] t -> vol_info =
"ocaml_libvirt_storage_vol_get_info"
+ external get_xml_desc : [`R] t -> xml =
"ocaml_libvirt_storage_vol_get_xml_desc"
+ external create_xml : [>`W] Pool.t -> xml -> unit =
"ocaml_libvirt_storage_vol_create_xml"
+ external delete : [>`W] t -> vol_delete_flags -> unit =
"ocaml_libvirt_storage_vol_delete"
+ external free : [>`R] t -> unit =
"ocaml_libvirt_storage_vol_free"
+ external const : [>`R] t -> ro t = "%identity"
+end
+
+module Secret +struct
+ type 'rw t
+ type secret_usage_type + | NoType
+ | Volume
+ | Ceph
+ | ISCSI
+ | TLS
+
+ external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t =
"ocaml_libvirt_secret_lookup_by_uuid"
+ external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t
= "ocaml_libvirt_secret_lookup_by_uuid_string"
+ external lookup_by_usage : 'a Connect.t -> secret_usage_type ->
string -> 'a t = "ocaml_libvirt_secret_lookup_by_usage"
+ external define_xml : [>`W] Connect.t -> xml -> rw t =
"ocaml_libvirt_secret_define_xml"
+ external get_uuid : [>`R] t -> uuid =
"ocaml_libvirt_secret_get_uuid"
+ external get_uuid_string : [>`R] t -> string =
"ocaml_libvirt_secret_get_uuid_string"
+ external get_usage_type : [>`R] t -> secret_usage_type =
"ocaml_libvirt_secret_get_usage_type"
+ external get_usage_id : [>`R] t -> string =
"ocaml_libvirt_secret_get_usage_id"
+ external get_xml_desc : [>`R] t -> xml =
"ocaml_libvirt_secret_get_xml_desc"
+ external set_value : [>`W] t -> bytes -> unit =
"ocaml_libvirt_secret_set_value"
+ external get_value : [>`R] t -> bytes =
"ocaml_libvirt_secret_get_value"
+ external undefine : [>`W] t -> unit =
"ocaml_libvirt_secret_undefine"
+ external free : [>`R] t -> unit = "ocaml_libvirt_secret_free"
+ external const : [>`R] t -> ro t = "%identity"
+end
+
+(* Initialization. *)
+external c_init : unit -> unit = "ocaml_libvirt_init"
+let () + Callback.register_exception
+ "ocaml_libvirt_virterror" (Virterror (Virterror.no_error ()));
+ Callback.register_exception
+ "ocaml_libvirt_not_supported" (Not_supported "");
+ c_init ();
+ Printexc.register_printer (
+ function
+ | Virterror e -> Some (Virterror.to_string e)
+ | _ -> None
+ )
diff --git a/common/mllibvirt/libvirt.mli b/common/mllibvirt/libvirt.mli
new file mode 100644
index 000000000..628f79715
--- /dev/null
+++ b/common/mllibvirt/libvirt.mli
@@ -0,0 +1,1626 @@
+(** OCaml bindings for libvirt. *)
+(* (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc.
+ https://libvirt.org/
+
+ This library 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; either
+ version 2 of the License, or (at your option) any later version,
+ with the OCaml linking exception described in ../COPYING.LIB.
+
+ This library 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.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+*)
+
+(**
+ {2 Introduction and examples}
+
+ This is a set of bindings for writing OCaml programs to
+ manage virtual machines through {{:https://libvirt.org/}libvirt}.
+
+ {3 Using libvirt interactively}
+
+ Using the interactive toplevel:
+
+{v
+$ ocaml -I +libvirt
+ Objective Caml version 3.10.0
+
+# #load "unix.cma";;
+# #load "mllibvirt.cma";;
+# let name = "test:///default";;
+val name : string = "test:///default"
+# let conn = Libvirt.Connect.connect_readonly ~name () ;;
+val conn : Libvirt.ro Libvirt.Connect.t = <abstr>
+# Libvirt.Connect.get_node_info conn;;
+ : Libvirt.Connect.node_info +{Libvirt.Connect.model = "i686";
Libvirt.Connect.memory = 3145728L;
+ Libvirt.Connect.cpus = 16; Libvirt.Connect.mhz = 1400;
+ Libvirt.Connect.nodes = 2; Libvirt.Connect.sockets = 2;
+ Libvirt.Connect.cores = 2; Libvirt.Connect.threads = 2}
+v}
+
+ {3 Compiling libvirt programs}
+
+ This command compiles a program to native code:
+
+{v
+ocamlopt -I +libvirt mllibvirt.cmxa list_domains.ml -o list_domains
+v}
+
+ {3 Example: Connect to the hypervisor}
+
+ The main modules are {!Libvirt.Connect}, {!Libvirt.Domain} and
+ {!Libvirt.Network} corresponding respectively to the
+ {{:https://libvirt.org/html/libvirt-libvirt-host.html}virConnect*},
+ {{:https://libvirt.org/html/libvirt-libvirt-domain.html}virDomain*}, and
+ {{:https://libvirt.org/html/libvirt-libvirt-network.html}virNetwork*}
+ functions from libvirt.
+ For brevity I usually rename these modules like this:
+
+{[
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+module N = Libvirt.Network
+]}
+
+ To get a connection handle, assuming a Xen hypervisor:
+
+{[
+let name = "xen:///"
+let conn = C.connect_readonly ~name ()
+]}
+
+ {3 Example: List running domains}
+
+{[
+open Printf
+
+let domains = D.get_domains conn [D.ListActive] in
+List.iter (
+ fun dom ->
+ printf "%8d %s\n%!" (D.get_id dom) (D.get_name dom)
+) domains;
+]}
+
+ {3 Example: List inactive domains}
+
+{[
+let domains = D.get_domains conn [D.ListInactive] in
+List.iter (
+ fun dom ->
+ printf "inactive %s\n%!" (D.get_name dom)
+) domains;
+]}
+
+ {3 Example: Print node info}
+
+{[
+let node_info = C.get_node_info conn in
+printf "model = %s\n" node_info.C.model;
+printf "memory = %Ld K\n" node_info.C.memory;
+printf "cpus = %d\n" node_info.C.cpus;
+printf "mhz = %d\n" node_info.C.mhz;
+printf "nodes = %d\n" node_info.C.nodes;
+printf "sockets = %d\n" node_info.C.sockets;
+printf "cores = %d\n" node_info.C.cores;
+printf "threads = %d\n%!" node_info.C.threads;
+
+let hostname = C.get_hostname conn in
+printf "hostname = %s\n%!" hostname;
+
+let uri = C.get_uri conn in
+printf "uri = %s\n%!" uri
+]}
+
+*)
+
+
+(** {2 Programming issues}
+
+ {3 General safety issues}
+
+ Memory allocation / automatic garbage collection of all libvirt
+ objects should be completely safe. If you find any safety issues
+ or if your pure OCaml program ever segfaults, please contact the author.
+
+ You can force a libvirt object to be freed early by calling
+ the {!Libvirt.Connect.close} function on the object. This shouldn't
+ affect the safety of garbage collection and should only be used when
+ you want to explicitly free memory. Note that explicitly
+ closing a connection object does nothing if there are still
+ unclosed domain or network objects referencing it.
+
+ Note that even though you hold open (eg) a domain object, that
+ doesn't mean that the domain (virtual machine) actually exists.
+ The domain could have been shut down or deleted by another user.
+ Thus domain objects can raise odd exceptions at any time.
+ This is just the nature of virtualisation.
+
+ {3 Backwards and forwards compatibility}
+
+ OCaml-libvirt requires libvirt version 1.0.2 or later. Future
+ releases of OCaml-libvirt will use newer features of libvirt
+ and therefore will require later versions of libvirt. It is always
+ possible to dynamically link your application against a newer
+ libvirt than OCaml-libvirt was originally compiled against.
+
+ {3 Get list of domains and domain infos}
+
+ This is a very common operation, and libvirt supports various
+ different methods to do it. We have hidden the complexity in a
+ flexible {!Libvirt.Domain.get_domains} and
+ {!Libvirt.Domain.get_domains_and_infos} calls which is easy to use and
+ automatically chooses the most efficient method depending on the
+ version of libvirt in use.
+
+ {3 Threads}
+
+ You can issue multiple concurrent libvirt requests in
+ different threads. However you must follow this rule:
+ Each thread must have its own separate libvirt connection, {i or}
+ you must implement your own mutex scheme to ensure that no
+ two threads can ever make concurrent calls using the same
+ libvirt connection.
+
+ (Note that multithreaded code is not well tested. If you find
+ bugs please report them.)
+
+ {3 Initialisation}
+
+ Libvirt requires all callers to call virInitialize before
+ using the library. This is done automatically for you by
+ these bindings when the program starts up, and we believe
+ that the way this is done is safe.
+
+ {2 Reference}
+*)
+
+type uuid = string
+ (** This is a "raw" UUID, ie. a packed string of bytes. *)
+
+type xml = string
+ (** Type of XML (an uninterpreted string of bytes). Use PXP, expat,
+ xml-light, etc. if you want to do anything useful with the XML.
+ *)
+
+type filename = string
+ (** A filename. *)
+
+val get_version : ?driver:string -> unit -> int * int
+ (** [get_version ()] returns the library version in the first part
+ of the tuple, and [0] in the second part.
+
+ [get_version ~driver ()] returns the library version in the first
+ part of the tuple, and the version of the driver called [driver]
+ in the second part.
+
+ The version numbers are encoded as
+ [major * 1_000_000 + minor * 1000 + release].
+ *)
+
+val uuid_length : int
+ (** Length of packed UUIDs. *)
+
+val uuid_string_length : int
+ (** Length of UUID strings. *)
+
+type rw = [`R|`W]
+type ro = [`R]
+ (** These
+
{{:https://caml.inria.fr/pub/ml-archives/caml-list/2004/07/80683af867cce6bf8fff273973f70c95.en.html}phantom
types}
+ are used to ensure the type-safety of read-only
+ versus read-write connections.
+
+ All connection/domain/etc. objects are marked with
+ a phantom read-write or read-only type, and trying to
+ pass a read-only object into a function which could
+ mutate the object will cause a compile time error.
+
+ Each module provides a function like {!Libvirt.Connect.const}
+ to demote a read-write object into a read-only object. The
+ opposite operation is, of course, not allowed.
+
+ If you want to handle both read-write and read-only
+ connections at runtime, use a variant similar to this:
+{[
+type conn_t + | No_connection
+ | Read_only of Libvirt.ro Libvirt.Connect.t
+ | Read_write of Libvirt.rw Libvirt.Connect.t
+]}
+ *)
+
+(** {3 Forward definitions}
+
+ These definitions are placed here to avoid the need to
+ use recursive module dependencies.
+*)
+
+(** {3 Connections} *)
+
+module Connect :
+sig
+ type 'rw t
+ (** Connection. Read-only connections have type [ro Connect.t] and
+ read-write connections have type [rw Connect.t].
+ *)
+
+ type node_info = {
+ model : string; (** CPU model *)
+ memory : int64; (** memory size in kilobytes *)
+ cpus : int; (** number of active CPUs *)
+ mhz : int; (** expected CPU frequency *)
+ nodes : int; (** number of NUMA nodes (1 = UMA) *)
+ sockets : int; (** number of CPU sockets per node *)
+ cores : int; (** number of cores per socket *)
+ threads : int; (** number of threads per core *)
+ }
+
+ type credential_type + | CredentialUsername (** Identity to act as *)
+ | CredentialAuthname (** Identify to authorize as *)
+ | CredentialLanguage (** RFC 1766 languages, comma separated *)
+ | CredentialCnonce (** client supplies a nonce *)
+ | CredentialPassphrase (** Passphrase secret *)
+ | CredentialEchoprompt (** Challenge response *)
+ | CredentialNoechoprompt (** Challenge response *)
+ | CredentialRealm (** Authentication realm *)
+ | CredentialExternal (** Externally managed credential *)
+
+ type credential = {
+ typ : credential_type; (** The type of credential *)
+ prompt : string; (** Prompt to show to user *)
+ challenge : string option; (** Additional challenge to show *)
+ defresult : string option; (** Optional default result *)
+ }
+
+ type auth = {
+ credtype : credential_type list; (** List of supported credential_type
values *)
+ cb : (credential list -> string option list);
+ (** Callback used to collect credentials.
+
+ The input is a list of all the requested credentials.
+
+ The function returns a list of all the results from the
+ requested credentials, so the number of results {e must} match
+ the number of input credentials. Each result is optional,
+ and in case it is [None] it means there was no result.
+ *)
+ }
+
+ val connect : ?name:string -> unit -> rw t
+ (** [connect ~name ()] connects to the hypervisor with URI [name].
+
+ [connect ()] connects to the default hypervisor.
+ *)
+ val connect_readonly : ?name:string -> unit -> ro t
+ (** [connect_readonly ~name ()] connects in read-only mode
+ to the hypervisor with URI [name].
+
+ [connect_readonly ()] connects in read-only mode to the
+ default hypervisor.
+ *)
+
+ val connect_auth : ?name:string -> auth -> rw t
+ (** [connect_auth ~name auth] connects to the hypervisor with URI
+ [name], using [auth] as authentication handler.
+
+ [connect_auth auth] connects to the default hypervisor, using
+ [auth] as authentication handler.
+ *)
+ val connect_auth_readonly : ?name:string -> auth -> ro t
+ (** [connect_auth_readonly ~name auth] connects in read-only mode
+ to the hypervisor with URI [name], using [auth] as authentication
+ handler.
+
+ [connect_auth_readonly auth] connects in read-only mode to the
+ default hypervisor, using [auth] as authentication handler.
+ *)
+
+ val close : [>`R] t -> unit
+ (** [close conn] closes and frees the connection object in memory.
+
+ The connection is automatically closed if it is garbage
+ collected. This function just forces it to be closed
+ and freed right away.
+ *)
+
+ val get_type : [>`R] t -> string
+ (** Returns the name of the driver (hypervisor). *)
+
+ val get_version : [>`R] t -> int
+ (** Returns the driver version
+ [major * 1_000_000 + minor * 1000 + release]
+ *)
+ val get_hostname : [>`R] t -> string
+ (** Returns the hostname of the physical server. *)
+ val get_uri : [>`R] t -> string
+ (** Returns the canonical connection URI. *)
+ val get_max_vcpus : [>`R] t -> ?type_:string -> unit -> int
+ (** Returns the maximum number of virtual CPUs
+ supported by a guest VM of a particular type. *)
+ val list_domains : [>`R] t -> int -> int array
+ (** [list_domains conn max] returns the running domain IDs,
+ up to a maximum of [max] entries.
+
+ Call {!num_of_domains} first to get a value for [max].
+
+ See also:
+ {!Libvirt.Domain.get_domains},
+ {!Libvirt.Domain.get_domains_and_infos}.
+ *)
+ val num_of_domains : [>`R] t -> int
+ (** Returns the number of running domains. *)
+ val get_capabilities : [>`R] t -> xml
+ (** Returns the hypervisor capabilities (as XML). *)
+ val num_of_defined_domains : [>`R] t -> int
+ (** Returns the number of inactive (shutdown) domains. *)
+ val list_defined_domains : [>`R] t -> int -> string array
+ (** [list_defined_domains conn max]
+ returns the names of the inactive domains, up to
+ a maximum of [max] entries.
+
+ Call {!num_of_defined_domains} first to get a value for [max].
+
+ See also:
+ {!Libvirt.Domain.get_domains},
+ {!Libvirt.Domain.get_domains_and_infos}.
+ *)
+ val num_of_networks : [>`R] t -> int
+ (** Returns the number of networks. *)
+ val list_networks : [>`R] t -> int -> string array
+ (** [list_networks conn max]
+ returns the names of the networks, up to a maximum
+ of [max] entries.
+ Call {!num_of_networks} first to get a value for [max].
+ *)
+ val num_of_defined_networks : [>`R] t -> int
+ (** Returns the number of inactive networks. *)
+ val list_defined_networks : [>`R] t -> int -> string array
+ (** [list_defined_networks conn max]
+ returns the names of the inactive networks, up to a maximum
+ of [max] entries.
+ Call {!num_of_defined_networks} first to get a value for [max].
+ *)
+
+ val num_of_pools : [>`R] t -> int
+ (** Returns the number of storage pools. *)
+ val list_pools : [>`R] t -> int -> string array
+ (** Return list of storage pools. *)
+ val num_of_defined_pools : [>`R] t -> int
+ (** Returns the number of storage pools. *)
+ val list_defined_pools : [>`R] t -> int -> string array
+ (** Return list of storage pools. *)
+
+ (* The name of this function is inconsistent, but the inconsistency
+ * is really in libvirt itself.
+ *)
+ val num_of_secrets : [>`R] t -> int
+ (** Returns the number of secrets. *)
+ val list_secrets : [>`R] t -> int -> string array
+ (** Returns the list of secrets. *)
+ val get_node_info : [>`R] t -> node_info
+ (** Return information about the physical server. *)
+
+ val node_get_free_memory : [> `R] t -> int64
+ (**
+ [node_get_free_memory conn]
+ returns the amount of free memory (not allocated to any guest)
+ in the machine.
+ *)
+
+ val node_get_cells_free_memory : [> `R] t -> int -> int -> int64
array
+ (**
+ [node_get_cells_free_memory conn start max]
+ returns the amount of free memory on each NUMA cell in kilobytes.
+ [start] is the first cell for which we return free memory.
+ [max] is the maximum number of cells for which we return free memory.
+ Returns an array of up to [max] entries in length.
+ *)
+
+ val maxcpus_of_node_info : node_info -> int
+ (** Calculate the total number of CPUs supported (but not necessarily
+ active) in the host.
+ *)
+
+ val cpumaplen : int -> int
+ (** Calculate the length (in bytes) required to store the complete
+ CPU map between a single virtual and all physical CPUs of a domain.
+ *)
+
+ val use_cpu : bytes -> int -> unit
+ (** [use_cpu cpumap cpu] marks [cpu] as usable in [cpumap]. *)
+ val unuse_cpu : bytes -> int -> unit
+ (** [unuse_cpu cpumap cpu] marks [cpu] as not usable in [cpumap]. *)
+ val cpu_usable : bytes -> int -> int -> int -> bool
+ (** [cpu_usable cpumaps maplen vcpu cpu] checks returns true iff the
+ [cpu] is usable by [vcpu]. *)
+
+ val set_keep_alive : [>`R] t -> int -> int -> unit
+ (** [set_keep_alive conn interval count] starts sending keepalive
+ messages after [interval] seconds of inactivity and consider the
+ connection to be broken when no response is received after [count]
+ keepalive messages.
+ Note: the client has to implement and run an event loop to
+ be able to use keep-alive messages. *)
+
+ val get_auth_default : unit -> auth
+ (** [get_auth_default ()] returns the default authentication handler
+ of libvirt.
+ *)
+
+ external const : [>`R] t -> ro t = "%identity"
+ (** [const conn] turns a read/write connection into a read-only
+ connection. Note that the opposite operation is impossible.
+ *)
+end
+ (** Module dealing with connections. [Connect.t] is the
+ connection object. *)
+
+(** {3 Domains} *)
+
+module Domain :
+sig
+ type 'rw t
+ (** Domain handle. Read-only handles have type [ro Domain.t] and
+ read-write handles have type [rw Domain.t].
+ *)
+
+ type state + | InfoNoState | InfoRunning | InfoBlocked | InfoPaused
+ | InfoShutdown | InfoShutoff | InfoCrashed | InfoPMSuspended
+
+ type info = {
+ state : state; (** running state *)
+ max_mem : int64; (** maximum memory in kilobytes *)
+ memory : int64; (** memory used in kilobytes *)
+ nr_virt_cpu : int; (** number of virtual CPUs *)
+ cpu_time : int64; (** CPU time used in nanoseconds *)
+ }
+
+ type vcpu_state = VcpuOffline | VcpuRunning | VcpuBlocked
+
+ type vcpu_info = {
+ number : int; (** virtual CPU number *)
+ vcpu_state : vcpu_state; (** state *)
+ vcpu_time : int64; (** CPU time used in nanoseconds *)
+ cpu : int; (** real CPU number, -1 if offline *)
+ }
+
+ type domain_create_flag + | START_PAUSED (** Launch
guest in paused state *)
+ | START_AUTODESTROY (** Automatically kill guest on close
*)
+ | START_BYPASS_CACHE (** Avoid filesystem cache pollution *)
+ | START_FORCE_BOOT (** Discard any managed save *)
+ | START_VALIDATE (** Validate XML against schema *)
+
+ type sched_param = string * sched_param_value
+ and sched_param_value + | SchedFieldInt32 of int32 | SchedFieldUInt32 of
int32
+ | SchedFieldInt64 of int64 | SchedFieldUInt64 of int64
+ | SchedFieldFloat of float | SchedFieldBool of bool
+
+ type typed_param = string * typed_param_value
+ and typed_param_value + | TypedFieldInt32 of int32 | TypedFieldUInt32 of
int32
+ | TypedFieldInt64 of int64 | TypedFieldUInt64 of int64
+ | TypedFieldFloat of float | TypedFieldBool of bool
+ | TypedFieldString of string
+
+ type migrate_flag = Live
+
+ type memory_flag = Virtual
+
+ type list_flag + | ListActive
+ | ListInactive
+ | ListAll
+
+ type block_stats = {
+ rd_req : int64;
+ rd_bytes : int64;
+ wr_req : int64;
+ wr_bytes : int64;
+ errs : int64;
+ }
+
+ type interface_stats = {
+ rx_bytes : int64;
+ rx_packets : int64;
+ rx_errs : int64;
+ rx_drop : int64;
+ tx_bytes : int64;
+ tx_packets : int64;
+ tx_errs : int64;
+ tx_drop : int64;
+ }
+
+ type get_all_domain_stats_flag + | GetAllDomainsStatsActive
+ | GetAllDomainsStatsInactive
+ | GetAllDomainsStatsOther
+ | GetAllDomainsStatsPaused
+ | GetAllDomainsStatsPersistent
+ | GetAllDomainsStatsRunning
+ | GetAllDomainsStatsShutoff
+ | GetAllDomainsStatsTransient
+ | GetAllDomainsStatsBacking
+ | GetAllDomainsStatsEnforceStats
+
+ type stats_type + | StatsState | StatsCpuTotal | StatsBalloon | StatsVcpu
+ | StatsInterface | StatsBlock | StatsPerf
+
+ type domain_stats_record = {
+ dom_uuid : uuid;
+ params : typed_param array;
+ }
+
+ type xml_desc_flag + | XmlSecure (** dump security sensitive information
too *)
+ | XmlInactive (** dump inactive domain information *)
+ | XmlUpdateCPU (** update guest CPU requirements according to host CPU *)
+ | XmlMigratable (** dump XML suitable for migration *)
+
+ val max_peek : [>`R] t -> int
+ (** Maximum size supported by the {!block_peek} and {!memory_peek}
+ functions. If you want to peek more than this then you must
+ break your request into chunks. *)
+
+ val create_linux : [>`W] Connect.t -> xml -> rw t
+ (** Create a new guest domain (not necessarily a Linux one)
+ from the given XML.
+ @deprecated Use {!create_xml} instead.
+ *)
+ val create_xml : [>`W] Connect.t -> xml -> domain_create_flag list
-> rw t
+ (** Create a new guest domain from the given XML. *)
+ val lookup_by_id : 'a Connect.t -> int -> 'a t
+ (** Lookup a domain by ID. *)
+ val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t
+ (** Lookup a domain by UUID. This uses the packed byte array UUID. *)
+ val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t
+ (** Lookup a domain by (string) UUID. *)
+ val lookup_by_name : 'a Connect.t -> string -> 'a t
+ (** Lookup a domain by name. *)
+ val destroy : [>`W] t -> unit
+ (** Abruptly destroy a domain. *)
+ val free : [>`R] t -> unit
+ (** [free domain] frees the domain object in memory.
+
+ The domain object is automatically freed if it is garbage
+ collected. This function just forces it to be freed right
+ away.
+ *)
+
+ val suspend : [>`W] t -> unit
+ (** Suspend a domain. *)
+ val resume : [>`W] t -> unit
+ (** Resume a domain. *)
+ val save : [>`W] t -> filename -> unit
+ (** Suspend a domain, then save it to the file. *)
+ val restore : [>`W] Connect.t -> filename -> unit
+ (** Restore a domain from a file. *)
+ val core_dump : [>`W] t -> filename -> unit
+ (** Force a domain to core dump to the named file. *)
+ val shutdown : [>`W] t -> unit
+ (** Shutdown a domain. *)
+ val reboot : [>`W] t -> unit
+ (** Reboot a domain. *)
+ val get_name : [>`R] t -> string
+ (** Get the domain name. *)
+ val get_uuid : [>`R] t -> uuid
+ (** Get the domain UUID (as a packed byte array). *)
+ val get_uuid_string : [>`R] t -> string
+ (** Get the domain UUID (as a printable string). *)
+ val get_id : [>`R] t -> int
+ (** [get_id dom] returns the ID of the domain. In most cases
+ this returns [-1] if the domain is not running. *)
+ val get_os_type : [>`R] t -> string
+ (** Get the operating system type. *)
+ val get_max_memory : [>`R] t -> int64
+ (** Get the maximum memory allocation. *)
+ val set_max_memory : [>`W] t -> int64 -> unit
+ (** Set the maximum memory allocation. *)
+ val set_memory : [>`W] t -> int64 -> unit
+ (** Set the normal memory allocation. *)
+ val get_info : [>`R] t -> info
+ (** Get information about a domain. *)
+ val get_xml_desc : [>`R] t -> xml
+ (** Get the XML description of a domain. *)
+ val get_xml_desc_flags : [>`W] t -> xml_desc_flag list -> xml
+ (** Get the XML description of a domain, with the possibility
+ to specify flags. *)
+ val get_scheduler_type : [>`R] t -> string * int
+ (** Get the scheduler type. *)
+ val get_scheduler_parameters : [>`R] t -> int -> sched_param array
+ (** Get the array of scheduler parameters. *)
+ val set_scheduler_parameters : [>`W] t -> sched_param array -> unit
+ (** Set the array of scheduler parameters. *)
+ val define_xml : [>`W] Connect.t -> xml -> rw t
+ (** Define a new domain (but don't start it up) from the XML. *)
+ val undefine : [>`W] t -> unit
+ (** Undefine a domain - removes its configuration. *)
+ val create : [>`W] t -> unit
+ (** Launch a defined (inactive) domain. *)
+ val get_autostart : [>`R] t -> bool
+ (** Get the autostart flag for a domain. *)
+ val set_autostart : [>`W] t -> bool -> unit
+ (** Set the autostart flag for a domain. *)
+ val set_vcpus : [>`W] t -> int -> unit
+ (** Change the number of vCPUs available to a domain. *)
+ val pin_vcpu : [>`W] t -> int -> string -> unit
+ (** [pin_vcpu dom vcpu bitmap] pins a domain vCPU to a bitmap of physical
+ CPUs. See the libvirt documentation for details of the
+ layout of the bitmap. *)
+ val get_vcpus : [>`R] t -> int -> int -> int * vcpu_info array *
string
+ (** [get_vcpus dom maxinfo maplen] returns the pinning information
+ for a domain. See the libvirt documentation for details
+ of the array and bitmap returned from this function.
+ *)
+ val get_cpu_stats : [>`R] t -> typed_param list array
+ (** [get_pcpu_stats dom] returns the physical CPU stats
+ for a domain. See the libvirt documentation for details.
+ *)
+ val get_max_vcpus : [>`R] t -> int
+ (** Returns the maximum number of vCPUs supported for this domain. *)
+ val attach_device : [>`W] t -> xml -> unit
+ (** Attach a device (described by the device XML) to a domain. *)
+ val detach_device : [>`W] t -> xml -> unit
+ (** Detach a device (described by the device XML) from a domain. *)
+
+ val migrate : [>`W] t -> [>`W] Connect.t -> migrate_flag list
->
+ ?dname:string -> ?uri:string -> ?bandwidth:int -> unit -> rw t
+ (** [migrate dom dconn flags ()] migrates a domain to a
+ destination host described by [dconn].
+
+ The optional flag [?dname] is used to rename the domain.
+
+ The optional flag [?uri] is used to route the migration.
+
+ The optional flag [?bandwidth] is used to limit the bandwidth
+ used for migration (in Mbps). *)
+
+ val block_stats : [>`R] t -> string -> block_stats
+ (** Returns block device stats. *)
+ val interface_stats : [>`R] t -> string -> interface_stats
+ (** Returns network interface stats. *)
+
+ val block_peek : [>`W] t -> string -> int64 -> int -> string
-> int -> unit
+ (** [block_peek dom path offset size buf boff] reads [size] bytes at
+ [offset] in the domain's [path] block device.
+
+ If successful then the data is written into [buf] starting
+ at offset [boff], for [size] bytes.
+
+ See also {!max_peek}. *)
+ val memory_peek : [>`W] t -> memory_flag list -> int64 -> int
->
+ string -> int -> unit
+ (** [memory_peek dom Virtual offset size] reads [size] bytes
+ at [offset] in the domain's virtual memory.
+
+ If successful then the data is written into [buf] starting
+ at offset [boff], for [size] bytes.
+
+ See also {!max_peek}. *)
+
+ external get_all_domain_stats : [>`R] Connect.t -> stats_type list
-> get_all_domain_stats_flag list -> domain_stats_record array =
"ocaml_libvirt_domain_get_all_domain_stats"
+ (** [get_all_domain_stats conn stats flags] allows you to read
+ all stats across multiple/all domains in a single call.
+
+ See the libvirt documentation for
+ [virConnectGetAllDomainStats]. *)
+
+ external const : [>`R] t -> ro t = "%identity"
+ (** [const dom] turns a read/write domain handle into a read-only
+ domain handle. Note that the opposite operation is impossible.
+ *)
+
+ val get_domains : ([>`R] as 'a) Connect.t -> list_flag list ->
'a t list
+ (** Get the active and/or inactive domains using the most
+ efficient method available.
+
+ See also:
+ {!get_domains_and_infos},
+ {!Connect.list_domains},
+ {!Connect.list_defined_domains}.
+ *)
+
+ val get_domains_and_infos : ([>`R] as 'a) Connect.t -> list_flag
list ->
+ ('a t * info) list
+ (** This gets the active and/or inactive domains and the
+ domain info for each one using the most efficient
+ method available.
+
+ See also:
+ {!get_domains},
+ {!Connect.list_domains},
+ {!Connect.list_defined_domains},
+ {!get_info}.
+ *)
+
+end
+ (** Module dealing with domains. [Domain.t] is the
+ domain object. *)
+
+module Event :
+sig
+
+ module Defined : sig
+ type t = [
+ | `Added (** Newly created config file *)
+ | `Updated (** Changed config file *)
+ | `Unknown of int
+ ]
+
+ val to_string: t -> string
+ end
+
+ module Undefined : sig
+ type t = [
+ | `Removed (** Deleted the config file *)
+ | `Unknown of int
+ ]
+
+ val to_string: t -> string
+ end
+
+ module Started : sig
+ type t = [
+ | `Booted (** Normal startup from boot *)
+ | `Migrated (** Incoming migration from another host *)
+ | `Restored (** Restored from a state file *)
+ | `FromSnapshot (** Restored from snapshot *)
+ | `Wakeup (** Started due to wakeup event *)
+ | `Unknown of int
+ ]
+
+ val to_string: t -> string
+ end
+
+ module Suspended : sig
+ type t = [
+ | `Paused (** Normal suspend due to admin pause *)
+ | `Migrated (** Suspended for offline migration *)
+ | `IOError (** Suspended due to a disk I/O error *)
+ | `Watchdog (** Suspended due to a watchdog firing *)
+ | `Restored (** Restored from paused state file *)
+ | `FromSnapshot (** Restored from paused snapshot *)
+ | `APIError (** suspended after failure during libvirt API call *)
+ | `Unknown of int
+ ]
+
+ val to_string: t -> string
+ end
+
+ module Resumed : sig
+ type t = [
+ | `Unpaused (** Normal resume due to admin unpause *)
+ | `Migrated (** Resumed for completion of migration *)
+ | `FromSnapshot (** Resumed from snapshot *)
+ | `Unknown of int
+ ]
+
+ val to_string: t -> string
+ end
+
+ module Stopped : sig
+ type t = [
+ | `Shutdown (** Normal shutdown *)
+ | `Destroyed (** Forced poweroff from host *)
+ | `Crashed (** Guest crashed *)
+ | `Migrated (** Migrated off to another host *)
+ | `Saved (** Saved to a state file *)
+ | `Failed (** Host emulator/mgmt failed *)
+ | `FromSnapshot (** offline snapshot loaded *)
+ | `Unknown of int
+ ]
+
+ val to_string: t -> string
+ end
+
+ module PM_suspended : sig
+ type t = [
+ | `Memory (** Guest was PM suspended to memory *)
+ | `Disk (** Guest was PM suspended to disk *)
+ | `Unknown of int
+ ]
+
+ val to_string: t -> string
+ end
+
+ module Lifecycle : sig
+ type t = [
+ | `Defined of Defined.t
+ | `Undefined of Undefined.t
+ | `Started of Started.t
+ | `Suspended of Suspended.t
+ | `Resumed of Resumed.t
+ | `Stopped of Stopped.t
+ | `Shutdown (* no detail defined yet *)
+ | `PMSuspended of PM_suspended.t
+ | `Unknown of int
+ ]
+
+ val to_string: t -> string
+ end
+
+ module Reboot : sig
+ type t = unit
+
+ val to_string: t -> string
+ end
+
+ module Rtc_change : sig
+ type t = int64
+
+ val to_string: t -> string
+ end
+
+ module Watchdog : sig
+ type t = [
+ | `None (** No action, watchdog ignored *)
+ | `Pause (** Guest CPUs are paused *)
+ | `Reset (** Guest CPUs are reset *)
+ | `Poweroff (** Guest is forcably powered off *)
+ | `Shutdown (** Guest is requested to gracefully shutdown *)
+ | `Debug (** No action, a debug message logged *)
+ | `Unknown of int (** newer libvirt *)
+ ]
+
+ val to_string: t -> string
+ end
+
+ module Io_error : sig
+ (** Represents both IOError and IOErrorReason *)
+ type action = [
+ | `None (** No action, IO error ignored *)
+ | `Pause (** Guest CPUs are paused *)
+ | `Report (** IO error reported to guest OS *)
+ | `Unknown of int (** newer libvirt *)
+ ]
+
+ type t = {
+ src_path: string option; (** The host file on which the I/O error
occurred *)
+ dev_alias: string option; (** The guest device alias associated with the
path *)
+ action: action; (** The action that is to be taken due to the IO error
*)
+ reason: string option; (** The cause of the IO error *)
+ }
+
+ val to_string: t -> string
+ end
+
+ module Graphics_address : sig
+ type family = [
+ | `Ipv4 (** IPv4 address *)
+ | `Ipv6 (** IPv6 address *)
+ | `Unix (** UNIX socket path *)
+ | `Unknown of int (** newer libvirt *)
+ ]
+
+ type t = {
+ family: family; (** Address family *)
+ node: string option; (** Address of node (eg IP address, or UNIX path
*)
+ service: string option; (** Service name/number (eg TCP port, or NULL) *)
+ }
+
+ val to_string: t -> string
+ end
+
+ module Graphics_subject : sig
+ type identity = {
+ ty: string option; (** Type of identity *)
+ name: string option; (** Identity value *)
+ }
+
+ type t = identity list
+
+ val to_string: t -> string
+ end
+
+ module Graphics : sig
+ type phase = [
+ | `Connect (** Initial socket connection established *)
+ | `Initialize (** Authentication & setup completed *)
+ | `Disconnect (** Final socket disconnection *)
+ | `Unknown of int (** newer libvirt *)
+ ]
+
+ type t = {
+ phase: phase; (** the phase of the connection *)
+ local: Graphics_address.t; (** the local server address *)
+ remote: Graphics_address.t; (** the remote client address *)
+ auth_scheme: string option; (** the authentication scheme activated *)
+ subject: Graphics_subject.t; (** the authenticated subject (user) *)
+ }
+
+ val to_string: t -> string
+ end
+
+ module Control_error : sig
+ type t = unit
+
+ val to_string: t -> string
+ end
+
+ module Block_job : sig
+ type ty = [
+ | `KnownUnknown (** explicitly named UNKNOWN in the spec *)
+ | `Pull
+ | `Copy
+ | `Commit
+ | `Unknown of int
+ ]
+
+ type status = [
+ | `Completed
+ | `Failed
+ | `Cancelled
+ | `Ready
+ | `Unknown of int
+ ]
+
+ type t = {
+ disk: string option; (** fully-qualified name of the affected disk *)
+ ty: ty; (** type of block job *)
+ status: status; (** final status of the operation *)
+ }
+
+ val to_string: t -> string
+ end
+
+ module Disk_change : sig
+ type reason = [
+ | `MissingOnStart
+ | `Unknown of int
+ ]
+
+ type t = {
+ old_src_path: string option; (** old source path *)
+ new_src_path: string option; (** new source path *)
+ dev_alias: string option; (** device alias name *)
+ reason: reason; (** reason why this callback was called *)
+ }
+
+ val to_string: t -> string
+ end
+
+ module Tray_change : sig
+ type reason = [
+ | `Open
+ | `Close
+ | `Unknown of int
+ ]
+
+ type t = {
+ dev_alias: string option; (** device alias *)
+ reason: reason; (** why the tray status was changed *)
+ }
+
+ val to_string: t -> string
+ end
+
+ module PM_wakeup : sig
+ type reason = [
+ | `Unknown of int
+ ]
+
+ type t = reason
+
+ val to_string: t -> string
+ end
+
+ module PM_suspend : sig
+ type reason = [
+ | `Unknown of int
+ ]
+
+ type t = reason
+
+ val to_string: t -> string
+ end
+
+ module Balloon_change : sig
+ type t = int64
+
+ val to_string: t -> string
+ end
+
+ module PM_suspend_disk : sig
+ type reason = [
+ | `Unknown of int
+ ]
+
+ type t = reason
+
+ val to_string: t -> string
+ end
+
+
+ type callback + | Lifecycle of ([`R] Domain.t -> Lifecycle.t ->
unit)
+ | Reboot of ([`R] Domain.t -> Reboot.t -> unit)
+ | RtcChange of ([`R] Domain.t -> Rtc_change.t -> unit)
+ | Watchdog of ([`R] Domain.t -> Watchdog.t -> unit)
+ | IOError of ([`R] Domain.t -> Io_error.t -> unit)
+ | Graphics of ([`R] Domain.t -> Graphics.t -> unit)
+ | IOErrorReason of ([`R] Domain.t -> Io_error.t -> unit)
+ | ControlError of ([`R] Domain.t -> Control_error.t -> unit)
+ | BlockJob of ([`R] Domain.t -> Block_job.t -> unit)
+ | DiskChange of ([`R] Domain.t -> Disk_change.t -> unit)
+ | TrayChange of ([`R] Domain.t -> Tray_change.t -> unit)
+ | PMWakeUp of ([`R] Domain.t -> PM_wakeup.t -> unit)
+ | PMSuspend of ([`R] Domain.t -> PM_suspend.t -> unit)
+ | BalloonChange of ([`R] Domain.t -> Balloon_change.t -> unit)
+ | PMSuspendDisk of ([`R] Domain.t -> PM_suspend_disk.t -> unit)
+
+ (** type of a registered call back function *)
+
+ val register_default_impl : unit -> unit
+ (** Registers the default event loop based on poll(). This
+ must be done before connections are opened.
+
+ Once registered call run_default_impl in a loop. *)
+
+ val run_default_impl : unit -> unit
+ (** Runs one iteration of the event loop. Applications will
+ generally want to have a thread which invokes this in an
+ infinite loop. *)
+
+ type callback_id
+ (** an individual event registration *)
+
+ val register_any : 'a Connect.t -> ?dom:'a Domain.t -> callback
-> callback_id
+ (** [register_any con ?dom callback] registers [callback]
+ to receive notification of arbitrary domain events. Return
+ a registration id which can be used in [deregister_any].
+
+ If [?dom] is [None] then register for this kind of event on
+ all domains. If [dom] is [Some d] then register for this
+ kind of event only on [d].
+ *)
+
+ val deregister_any : 'a Connect.t -> callback_id -> unit
+ (** [deregister_any con id] deregisters the previously registered
+ callback with id [id]. *)
+
+ type timer_id
+ (** an individual timer event *)
+
+ val add_timeout : 'a Connect.t -> int -> (unit -> unit) ->
timer_id
+ (** [add_timeout con ms cb] registers [cb] as a timeout callback
+ which will be called every [ms] milliseconds *)
+
+ val remove_timeout : 'a Connect.t -> timer_id -> unit
+ (** [remove_timeout con t] deregisters timeout callback [t]. *)
+
+end
+ (** Module dealing with events generated by domain
+ state changes. *)
+
+(** {3 Networks} *)
+
+module Network :
+sig
+ type 'rw t
+ (** Network handle. Read-only handles have type [ro Network.t] and
+ read-write handles have type [rw Network.t].
+ *)
+
+ val lookup_by_name : 'a Connect.t -> string -> 'a t
+ (** Lookup a network by name. *)
+ val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t
+ (** Lookup a network by (packed) UUID. *)
+ val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t
+ (** Lookup a network by UUID string. *)
+ val create_xml : [>`W] Connect.t -> xml -> rw t
+ (** Create a network. *)
+ val define_xml : [>`W] Connect.t -> xml -> rw t
+ (** Define but don't activate a network. *)
+ val undefine : [>`W] t -> unit
+ (** Undefine configuration of a network. *)
+ val create : [>`W] t -> unit
+ (** Start up a defined (inactive) network. *)
+ val destroy : [>`W] t -> unit
+ (** Destroy a network. *)
+ val free : [>`R] t -> unit
+ (** [free network] frees the network object in memory.
+
+ The network object is automatically freed if it is garbage
+ collected. This function just forces it to be freed right
+ away.
+ *)
+
+ val get_name : [>`R] t -> string
+ (** Get network name. *)
+ val get_uuid : [>`R] t -> uuid
+ (** Get network packed UUID. *)
+ val get_uuid_string : [>`R] t -> string
+ (** Get network UUID as a printable string. *)
+ val get_xml_desc : [>`R] t -> xml
+ (** Get XML description of a network. *)
+ val get_bridge_name : [>`R] t -> string
+ (** Get bridge device name of a network. *)
+ val get_autostart : [>`R] t -> bool
+ (** Get the autostart flag for a network. *)
+ val set_autostart : [>`W] t -> bool -> unit
+ (** Set the autostart flag for a network. *)
+
+ external const : [>`R] t -> ro t = "%identity"
+ (** [const network] turns a read/write network handle into a read-only
+ network handle. Note that the opposite operation is impossible.
+ *)
+end
+ (** Module dealing with networks. [Network.t] is the
+ network object. *)
+
+(** {3 Storage pools} *)
+
+module Pool :
+sig
+ type 'rw t
+ (** Storage pool handle. *)
+
+ type pool_state = Inactive | Building | Running | Degraded | Inaccessible
+ (** State of the storage pool. *)
+
+ type pool_build_flags = New | Repair | Resize
+ (** Flags for creating a storage pool. *)
+
+ type pool_delete_flags = Normal | Zeroed
+ (** Flags for deleting a storage pool. *)
+
+ type pool_info = {
+ state : pool_state; (** Pool state. *)
+ capacity : int64; (** Logical size in bytes. *)
+ allocation : int64; (** Currently allocated in bytes. *)
+ available : int64; (** Remaining free space bytes. *)
+ }
+
+ val lookup_by_name : 'a Connect.t -> string -> 'a t
+ val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t
+ val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t
+ (** Look up a storage pool by name, UUID or UUID string. *)
+
+ val create_xml : [>`W] Connect.t -> xml -> rw t
+ (** Create a storage pool. *)
+ val define_xml : [>`W] Connect.t -> xml -> rw t
+ (** Define but don't activate a storage pool. *)
+ val build : [>`W] t -> pool_build_flags -> unit
+ (** Build a storage pool. *)
+ val undefine : [>`W] t -> unit
+ (** Undefine configuration of a storage pool. *)
+ val create : [>`W] t -> unit
+ (** Start up a defined (inactive) storage pool. *)
+ val destroy : [>`W] t -> unit
+ (** Destroy a storage pool. *)
+ val delete : [>`W] t -> unit
+ (** Delete a storage pool. *)
+ val free : [>`R] t -> unit
+ (** Free a storage pool object in memory.
+
+ The storage pool object is automatically freed if it is garbage
+ collected. This function just forces it to be freed right
+ away.
+ *)
+ val refresh : [`R] t -> unit
+ (** Refresh the list of volumes in the storage pool. *)
+
+ val get_name : [`R] t -> string
+ (** Name of the pool. *)
+ val get_uuid : [`R] t -> uuid
+ (** Get the UUID (as a packed byte array). *)
+ val get_uuid_string : [`R] t -> string
+ (** Get the UUID (as a printable string). *)
+ val get_info : [`R] t -> pool_info
+ (** Get information about the pool. *)
+ val get_xml_desc : [`R] t -> xml
+ (** Get the XML description. *)
+ val get_autostart : [`R] t -> bool
+ (** Get the autostart flag for the storage pool. *)
+ val set_autostart : [>`W] t -> bool -> unit
+ (** Set the autostart flag for the storage pool. *)
+
+ val num_of_volumes : [`R] t -> int
+ (** Returns the number of storage volumes within the storage pool. *)
+ val list_volumes : [`R] t -> int -> string array
+ (** Return list of storage volumes. *)
+
+ external const : [>`R] t -> ro t = "%identity"
+ (** [const conn] turns a read/write storage pool into a read-only
+ pool. Note that the opposite operation is impossible.
+ *)
+end
+ (** Module dealing with storage pools. *)
+
+(** {3 Storage volumes} *)
+
+module Volume :
+sig
+ type 'rw t
+ (** Storage volume handle. *)
+
+ type vol_type = File | Block | Dir | Network | NetDir | Ploop
+ (** Type of a storage volume. *)
+
+ type vol_delete_flags = Normal | Zeroed
+ (** Flags for deleting a storage volume. *)
+
+ type vol_info = {
+ typ : vol_type; (** Type of storage volume. *)
+ capacity : int64; (** Logical size in bytes. *)
+ allocation : int64; (** Currently allocated in bytes. *)
+ }
+
+ val lookup_by_name : 'a Pool.t -> string -> 'a t
+ val lookup_by_key : 'a Connect.t -> string -> 'a t
+ val lookup_by_path : 'a Connect.t -> string -> 'a t
+ (** Look up a storage volume by name, key or path volume. *)
+
+ val pool_of_volume : 'a t -> 'a Pool.t
+ (** Get the storage pool containing this volume. *)
+
+ val get_name : [`R] t -> string
+ (** Name of the volume. *)
+ val get_key : [`R] t -> string
+ (** Key of the volume. *)
+ val get_path : [`R] t -> string
+ (** Path of the volume. *)
+ val get_info : [`R] t -> vol_info
+ (** Get information about the storage volume. *)
+ val get_xml_desc : [`R] t -> xml
+ (** Get the XML description. *)
+
+ val create_xml : [>`W] Pool.t -> xml -> unit
+ (** Create a storage volume. *)
+ val delete : [>`W] t -> vol_delete_flags -> unit
+ (** Delete a storage volume. *)
+ val free : [>`R] t -> unit
+ (** Free a storage volume object in memory.
+
+ The storage volume object is automatically freed if it is garbage
+ collected. This function just forces it to be freed right
+ away.
+ *)
+
+ external const : [>`R] t -> ro t = "%identity"
+ (** [const conn] turns a read/write storage volume into a read-only
+ volume. Note that the opposite operation is impossible.
+ *)
+end
+ (** Module dealing with storage volumes. *)
+
+(** {3 Secrets} *)
+
+module Secret :
+sig
+ type 'rw t
+ (** Secret handle. *)
+
+ type secret_usage_type + | NoType
+ | Volume
+ | Ceph
+ | ISCSI
+ | TLS
+ (** Usage type of a secret. *)
+
+ val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t
+ (** Lookup a secret by UUID. This uses the packed byte array UUID. *)
+ val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t
+ (** Lookup a secret by (string) UUID. *)
+ val lookup_by_usage : 'a Connect.t -> secret_usage_type -> string
-> 'a t
+ (** Lookup a secret by usage type, and usage ID. *)
+
+ val define_xml : [>`W] Connect.t -> xml -> rw t
+ (** Define a secret. *)
+
+ val get_uuid : [>`R] t -> uuid
+ (** Get the UUID (as a packed byte array) of the secret. *)
+ val get_uuid_string : [>`R] t -> string
+ (** Get the UUID (as a printable string) of the secret. *)
+ val get_usage_type : [>`R] t -> secret_usage_type
+ (** Get the usage type of the secret. *)
+ val get_usage_id : [>`R] t -> string
+ (** Get the usage ID of the secret. *)
+ val get_xml_desc : [>`R] t -> xml
+ (** Get the XML description. *)
+
+ val set_value : [>`W] t -> bytes -> unit
+ (** Set a new value for the secret. *)
+ val get_value : [>`R] t -> bytes
+ (** Get the value of the secret. *)
+
+ val undefine : [>`W] t -> unit
+ (** Undefine a secret. *)
+
+ val free : [>`R] t -> unit
+ (** Free a secret object in memory.
+
+ The secret object is automatically freed if it is garbage
+ collected. This function just forces it to be freed right
+ away.
+ *)
+
+ external const : [>`R] t -> ro t = "%identity"
+ (** [const conn] turns a read/write secret into a read-only
+ secret. Note that the opposite operation is impossible.
+ *)
+end
+ (** Module dealing with secrets. *)
+
+(** {3 Error handling and exceptions} *)
+
+module Virterror :
+sig
+ type code + | VIR_ERR_OK
+ | VIR_ERR_INTERNAL_ERROR
+ | VIR_ERR_NO_MEMORY
+ | VIR_ERR_NO_SUPPORT
+ | VIR_ERR_UNKNOWN_HOST
+ | VIR_ERR_NO_CONNECT
+ | VIR_ERR_INVALID_CONN
+ | VIR_ERR_INVALID_DOMAIN
+ | VIR_ERR_INVALID_ARG
+ | VIR_ERR_OPERATION_FAILED
+ | VIR_ERR_GET_FAILED
+ | VIR_ERR_POST_FAILED
+ | VIR_ERR_HTTP_ERROR
+ | VIR_ERR_SEXPR_SERIAL
+ | VIR_ERR_NO_XEN
+ | VIR_ERR_XEN_CALL
+ | VIR_ERR_OS_TYPE
+ | VIR_ERR_NO_KERNEL
+ | VIR_ERR_NO_ROOT
+ | VIR_ERR_NO_SOURCE
+ | VIR_ERR_NO_TARGET
+ | VIR_ERR_NO_NAME
+ | VIR_ERR_NO_OS
+ | VIR_ERR_NO_DEVICE
+ | VIR_ERR_NO_XENSTORE
+ | VIR_ERR_DRIVER_FULL
+ | VIR_ERR_CALL_FAILED
+ | VIR_ERR_XML_ERROR
+ | VIR_ERR_DOM_EXIST
+ | VIR_ERR_OPERATION_DENIED
+ | VIR_ERR_OPEN_FAILED
+ | VIR_ERR_READ_FAILED
+ | VIR_ERR_PARSE_FAILED
+ | VIR_ERR_CONF_SYNTAX
+ | VIR_ERR_WRITE_FAILED
+ | VIR_ERR_XML_DETAIL
+ | VIR_ERR_INVALID_NETWORK
+ | VIR_ERR_NETWORK_EXIST
+ | VIR_ERR_SYSTEM_ERROR
+ | VIR_ERR_RPC
+ | VIR_ERR_GNUTLS_ERROR
+ | VIR_WAR_NO_NETWORK
+ | VIR_ERR_NO_DOMAIN
+ | VIR_ERR_NO_NETWORK
+ | VIR_ERR_INVALID_MAC
+ | VIR_ERR_AUTH_FAILED
+ | VIR_ERR_INVALID_STORAGE_POOL
+ | VIR_ERR_INVALID_STORAGE_VOL
+ | VIR_WAR_NO_STORAGE
+ | VIR_ERR_NO_STORAGE_POOL
+ | VIR_ERR_NO_STORAGE_VOL
+ | VIR_WAR_NO_NODE
+ | VIR_ERR_INVALID_NODE_DEVICE
+ | VIR_ERR_NO_NODE_DEVICE
+ | VIR_ERR_NO_SECURITY_MODEL
+ | VIR_ERR_OPERATION_INVALID
+ | VIR_WAR_NO_INTERFACE
+ | VIR_ERR_NO_INTERFACE
+ | VIR_ERR_INVALID_INTERFACE
+ | VIR_ERR_MULTIPLE_INTERFACES
+ | VIR_WAR_NO_NWFILTER
+ | VIR_ERR_INVALID_NWFILTER
+ | VIR_ERR_NO_NWFILTER
+ | VIR_ERR_BUILD_FIREWALL
+ | VIR_WAR_NO_SECRET
+ | VIR_ERR_INVALID_SECRET
+ | VIR_ERR_NO_SECRET
+ | VIR_ERR_CONFIG_UNSUPPORTED
+ | VIR_ERR_OPERATION_TIMEOUT
+ | VIR_ERR_MIGRATE_PERSIST_FAILED
+ | VIR_ERR_HOOK_SCRIPT_FAILED
+ | VIR_ERR_INVALID_DOMAIN_SNAPSHOT
+ | VIR_ERR_NO_DOMAIN_SNAPSHOT
+ | VIR_ERR_INVALID_STREAM
+ | VIR_ERR_ARGUMENT_UNSUPPORTED
+ | VIR_ERR_STORAGE_PROBE_FAILED
+ | VIR_ERR_STORAGE_POOL_BUILT
+ | VIR_ERR_SNAPSHOT_REVERT_RISKY
+ | VIR_ERR_OPERATION_ABORTED
+ | VIR_ERR_AUTH_CANCELLED
+ | VIR_ERR_NO_DOMAIN_METADATA
+ | VIR_ERR_MIGRATE_UNSAFE
+ | VIR_ERR_OVERFLOW
+ | VIR_ERR_BLOCK_COPY_ACTIVE
+ | VIR_ERR_OPERATION_UNSUPPORTED
+ | VIR_ERR_SSH
+ | VIR_ERR_AGENT_UNRESPONSIVE
+ | VIR_ERR_RESOURCE_BUSY
+ | VIR_ERR_ACCESS_DENIED
+ | VIR_ERR_DBUS_SERVICE
+ | VIR_ERR_STORAGE_VOL_EXIST
+ | VIR_ERR_CPU_INCOMPATIBLE
+ | VIR_ERR_XML_INVALID_SCHEMA
+ | VIR_ERR_MIGRATE_FINISH_OK
+ | VIR_ERR_AUTH_UNAVAILABLE
+ | VIR_ERR_NO_SERVER
+ | VIR_ERR_NO_CLIENT
+ | VIR_ERR_AGENT_UNSYNCED
+ | VIR_ERR_LIBSSH
+ | VIR_ERR_DEVICE_MISSING
+ | VIR_ERR_INVALID_NWFILTER_BINDING
+ | VIR_ERR_NO_NWFILTER_BINDING
+ (* ^^ NB: If you add a variant you MUST edit
+ libvirt_c_epilogue.c:MAX_VIR_* *)
+ | VIR_ERR_UNKNOWN of int (** Other error, not handled with existing values.
*)
+ (** See [<libvirt/virterror.h>] for meaning of these codes. *)
+
+ val string_of_code : code -> string
+
+ type domain + | VIR_FROM_NONE
+ | VIR_FROM_XEN
+ | VIR_FROM_XEND
+ | VIR_FROM_XENSTORE
+ | VIR_FROM_SEXPR
+ | VIR_FROM_XML
+ | VIR_FROM_DOM
+ | VIR_FROM_RPC
+ | VIR_FROM_PROXY
+ | VIR_FROM_CONF
+ | VIR_FROM_QEMU
+ | VIR_FROM_NET
+ | VIR_FROM_TEST
+ | VIR_FROM_REMOTE
+ | VIR_FROM_OPENVZ
+ | VIR_FROM_XENXM
+ | VIR_FROM_STATS_LINUX
+ | VIR_FROM_LXC
+ | VIR_FROM_STORAGE
+ | VIR_FROM_NETWORK
+ | VIR_FROM_DOMAIN
+ | VIR_FROM_UML
+ | VIR_FROM_NODEDEV
+ | VIR_FROM_XEN_INOTIFY
+ | VIR_FROM_SECURITY
+ | VIR_FROM_VBOX
+ | VIR_FROM_INTERFACE
+ | VIR_FROM_ONE
+ | VIR_FROM_ESX
+ | VIR_FROM_PHYP
+ | VIR_FROM_SECRET
+ | VIR_FROM_CPU
+ | VIR_FROM_XENAPI
+ | VIR_FROM_NWFILTER
+ | VIR_FROM_HOOK
+ | VIR_FROM_DOMAIN_SNAPSHOT
+ | VIR_FROM_AUDIT
+ | VIR_FROM_SYSINFO
+ | VIR_FROM_STREAMS
+ | VIR_FROM_VMWARE
+ | VIR_FROM_EVENT
+ | VIR_FROM_LIBXL
+ | VIR_FROM_LOCKING
+ | VIR_FROM_HYPERV
+ | VIR_FROM_CAPABILITIES
+ | VIR_FROM_URI
+ | VIR_FROM_AUTH
+ | VIR_FROM_DBUS
+ | VIR_FROM_PARALLELS
+ | VIR_FROM_DEVICE
+ | VIR_FROM_SSH
+ | VIR_FROM_LOCKSPACE
+ | VIR_FROM_INITCTL
+ | VIR_FROM_IDENTITY
+ | VIR_FROM_CGROUP
+ | VIR_FROM_ACCESS
+ | VIR_FROM_SYSTEMD
+ | VIR_FROM_BHYVE
+ | VIR_FROM_CRYPTO
+ | VIR_FROM_FIREWALL
+ | VIR_FROM_POLKIT
+ | VIR_FROM_THREAD
+ | VIR_FROM_ADMIN
+ | VIR_FROM_LOGGING
+ | VIR_FROM_XENXL
+ | VIR_FROM_PERF
+ | VIR_FROM_LIBSSH
+ | VIR_FROM_RESCTRL
+ (* ^^ NB: If you add a variant you MUST edit
+ libvirt_c_epilogue.c: MAX_VIR_* *)
+ | VIR_FROM_UNKNOWN of int (** Other domain, not handled with existing
values. *)
+ (** Subsystem / driver which produced the error. *)
+
+ val string_of_domain : domain -> string
+
+ type level + | VIR_ERR_NONE
+ | VIR_ERR_WARNING
+ | VIR_ERR_ERROR
+ (* ^^ NB: If you add a variant you MUST edit libvirt_c.c: MAX_VIR_* *)
+ | VIR_ERR_UNKNOWN_LEVEL of int (** Other level, not handled with existing
values. *)
+ (** No error, a warning or an error. *)
+
+ val string_of_level : level -> string
+
+ type t = {
+ code : code; (** Error code. *)
+ domain : domain; (** Origin of the error. *)
+ message : string option; (** Human-readable message. *)
+ level : level; (** Error or warning. *)
+ str1 : string option; (** Informational string. *)
+ str2 : string option; (** Informational string. *)
+ str3 : string option; (** Informational string. *)
+ int1 : int32; (** Informational integer. *)
+ int2 : int32; (** Informational integer. *)
+ }
+ (** An error object. *)
+
+ val to_string : t -> string
+ (** Turn the exception into a printable string. *)
+
+ val get_last_error : unit -> t option
+ val get_last_conn_error : [>`R] Connect.t -> t option
+ (** Get the last error at a global or connection level.
+
+ Normally you do not need to use these functions because
+ the library automatically turns errors into exceptions.
+ *)
+
+ val reset_last_error : unit -> unit
+ val reset_last_conn_error : [>`R] Connect.t -> unit
+ (** Reset the error at a global or connection level.
+
+ Normally you do not need to use these functions.
+ *)
+
+ val no_error : unit -> t
+ (** Creates an empty error message.
+
+ Normally you do not need to use this function.
+ *)
+end
+ (** Module dealing with errors. *)
+
+exception Virterror of Virterror.t
+(** This exception can be raised by any library function that detects
+ an error. To get a printable error message, call
+ {!Virterror.to_string} on the content of this exception.
+*)
+
+exception Not_supported of string
+(**
+ Functions may raise
+ [Not_supported "virFoo"]
+ (where [virFoo] is the libvirt function name) if a function is
+ not supported at either compile or run time. This applies to
+ any libvirt function added after version 0.2.1.
+
+ See also
{{:https://libvirt.org/hvsupport.html}https://libvirt.org/hvsupport.html}
+*)
+
+(** {3 Utility functions} *)
+
+val map_ignore_errors : ('a -> 'b) -> 'a list -> 'b
list
+(** [map_ignore_errors f xs] calls function [f] for each element of [xs].
+
+ This is just like [List.map] except that if [f x] throws a
+ {!Virterror.t} exception, the error is ignored and [f x]
+ is not returned in the final list.
+
+ This function is primarily useful when dealing with domains which
+ might 'disappear' asynchronously from the currently running
+ program.
+*)
diff --git a/common/mllibvirt/libvirt_c_epilogue.c
b/common/mllibvirt/libvirt_c_epilogue.c
new file mode 100644
index 000000000..4e75d2f34
--- /dev/null
+++ b/common/mllibvirt/libvirt_c_epilogue.c
@@ -0,0 +1,462 @@
+/* OCaml bindings for libvirt.
+ * (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+ * https://libvirt.org/
+ *
+ * This library 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; either
+ * version 2 of the License, or (at your option) any later version,
+ * with the OCaml linking exception described in ../COPYING.LIB.
+ *
+ * This library 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.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+ */
+
+/* Please read libvirt/README file. */
+
+static const char *
+Optstring_val (value strv)
+{
+ if (strv == Val_int (0)) /* None */
+ return NULL;
+ else /* Some string */
+ return String_val (Field (strv, 0));
+}
+
+static value
+Val_opt (void *ptr, Val_ptr_t Val_ptr)
+{
+ CAMLparam0 ();
+ CAMLlocal2 (optv, ptrv);
+
+ if (ptr) { /* Some ptr */
+ optv = caml_alloc (1, 0);
+ ptrv = Val_ptr (ptr);
+ Store_field (optv, 0, ptrv);
+ } else /* None */
+ optv = Val_int (0);
+
+ CAMLreturn (optv);
+}
+
+static value
+Val_opt_const (const void *ptr, Val_const_ptr_t Val_ptr)
+{
+ CAMLparam0 ();
+ CAMLlocal2 (optv, ptrv);
+
+ if (ptr) { /* Some ptr */
+ optv = caml_alloc (1, 0);
+ ptrv = Val_ptr (ptr);
+ Store_field (optv, 0, ptrv);
+ } else /* None */
+ optv = Val_int (0);
+
+ CAMLreturn (optv);
+}
+
+#if 0
+static value
+option_default (value option, value deflt)
+{
+ if (option == Val_int (0)) /* "None" */
+ return deflt;
+ else /* "Some 'a" */
+ return Field (option, 0);
+}
+#endif
+
+static void
+_raise_virterror (const char *fn)
+{
+ CAMLparam0 ();
+ CAMLlocal1 (rv);
+ virErrorPtr errp;
+ struct _virError err;
+
+ errp = virGetLastError ();
+
+ if (!errp) {
+ /* Fake a _virError structure. */
+ memset (&err, 0, sizeof err);
+ err.code = VIR_ERR_INTERNAL_ERROR;
+ err.domain = VIR_FROM_NONE;
+ err.level = VIR_ERR_ERROR;
+ err.message = (char *) fn;
+ errp = &err;
+ }
+
+ rv = Val_virterror (errp);
+ caml_raise_with_arg (*caml_named_value ("ocaml_libvirt_virterror"),
rv);
+
+ /*NOTREACHED*/
+ /* Suppresses a compiler warning. */
+ (void) caml__frame;
+}
+
+static int
+_list_length (value listv)
+{
+ CAMLparam1 (listv);
+ int len = 0;
+
+ for (; listv != Val_emptylist; listv = Field (listv, 1), ++len) {}
+
+ CAMLreturnT (int, len);
+}
+
+static value
+Val_virconnectcredential (const virConnectCredentialPtr cred)
+{
+ CAMLparam0 ();
+ CAMLlocal1 (rv);
+
+ rv = caml_alloc (4, 0);
+ Store_field (rv, 0, Val_int (cred->type - 1));
+ Store_field (rv, 1, caml_copy_string (cred->prompt));
+ Store_field (rv, 2,
+ Val_opt_const (cred->challenge,
+ (Val_const_ptr_t) caml_copy_string));
+ Store_field (rv, 3,
+ Val_opt_const (cred->defresult,
+ (Val_const_ptr_t) caml_copy_string));
+
+ CAMLreturn (rv);
+}
+
+/* Convert the virErrorNumber, virErrorDomain and virErrorLevel enums
+ * into values (longs because they are variants in OCaml).
+ *
+ * The enum values are part of the libvirt ABI so they cannot change,
+ * which means that we can convert these numbers directly into
+ * OCaml variants (which use the same ordering) very fast.
+ *
+ * The tricky part here is when we are linked to a newer version of
+ * libvirt than the one we were compiled against. If the newer libvirt
+ * generates an error code which we don't know about then we need
+ * to convert it into VIR_*_UNKNOWN (code).
+ */
+
+#define MAX_VIR_CODE 101 /* VIR_ERR_NO_NWFILTER_BINDING */
+#define MAX_VIR_DOMAIN 67 /* VIR_FROM_RESCTRL */
+#define MAX_VIR_LEVEL VIR_ERR_ERROR
+
+static inline value
+Val_err_number (virErrorNumber code)
+{
+ CAMLparam0 ();
+ CAMLlocal1 (rv);
+
+ if (0 <= (int) code && code <= MAX_VIR_CODE)
+ rv = Val_int (code);
+ else {
+ rv = caml_alloc (1, 0); /* VIR_ERR_UNKNOWN (code) */
+ Store_field (rv, 0, Val_int (code));
+ }
+
+ CAMLreturn (rv);
+}
+
+static inline value
+Val_err_domain (virErrorDomain code)
+{
+ CAMLparam0 ();
+ CAMLlocal1 (rv);
+
+ if (0 <= (int) code && code <= MAX_VIR_DOMAIN)
+ rv = Val_int (code);
+ else {
+ rv = caml_alloc (1, 0); /* VIR_FROM_UNKNOWN (code) */
+ Store_field (rv, 0, Val_int (code));
+ }
+
+ CAMLreturn (rv);
+}
+
+static inline value
+Val_err_level (virErrorLevel code)
+{
+ CAMLparam0 ();
+ CAMLlocal1 (rv);
+
+ if (0 <= (int) code && code <= MAX_VIR_LEVEL)
+ rv = Val_int (code);
+ else {
+ rv = caml_alloc (1, 0); /* VIR_ERR_UNKNOWN_LEVEL (code) */
+ Store_field (rv, 0, Val_int (code));
+ }
+
+ CAMLreturn (rv);
+}
+
+/* Convert a virterror to a value. */
+static value
+Val_virterror (virErrorPtr err)
+{
+ CAMLparam0 ();
+ CAMLlocal3 (rv, connv, optv);
+
+ rv = caml_alloc (9, 0);
+ Store_field (rv, 0, Val_err_number (err->code));
+ Store_field (rv, 1, Val_err_domain (err->domain));
+ Store_field (rv, 2,
+ Val_opt (err->message, (Val_ptr_t) caml_copy_string));
+ Store_field (rv, 3, Val_err_level (err->level));
+
+ Store_field (rv, 4,
+ Val_opt (err->str1, (Val_ptr_t) caml_copy_string));
+ Store_field (rv, 5,
+ Val_opt (err->str2, (Val_ptr_t) caml_copy_string));
+ Store_field (rv, 6,
+ Val_opt (err->str3, (Val_ptr_t) caml_copy_string));
+ Store_field (rv, 7, caml_copy_int32 (err->int1));
+ Store_field (rv, 8, caml_copy_int32 (err->int2));
+
+ CAMLreturn (rv);
+}
+
+static void conn_finalize (value);
+static void dom_finalize (value);
+static void net_finalize (value);
+static void pol_finalize (value);
+static void vol_finalize (value);
+static void sec_finalize (value);
+
+static struct custom_operations conn_custom_operations = {
+ (char *) "conn_custom_operations",
+ conn_finalize,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+static struct custom_operations dom_custom_operations = {
+ (char *) "dom_custom_operations",
+ dom_finalize,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+
+};
+
+static struct custom_operations net_custom_operations = {
+ (char *) "net_custom_operations",
+ net_finalize,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+static struct custom_operations pol_custom_operations = {
+ (char *) "pol_custom_operations",
+ pol_finalize,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+static struct custom_operations vol_custom_operations = {
+ (char *) "vol_custom_operations",
+ vol_finalize,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+static struct custom_operations sec_custom_operations = {
+ (char *) "sec_custom_operations",
+ sec_finalize,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+static value
+Val_connect (virConnectPtr conn)
+{
+ CAMLparam0 ();
+ CAMLlocal1 (rv);
+ rv = caml_alloc_custom (&conn_custom_operations,
+ sizeof (virConnectPtr), 0, 1);
+ Connect_val (rv) = conn;
+ CAMLreturn (rv);
+}
+
+static value
+Val_dom (virDomainPtr dom)
+{
+ CAMLparam0 ();
+ CAMLlocal1 (rv);
+ rv = caml_alloc_custom (&dom_custom_operations,
+ sizeof (virDomainPtr), 0, 1);
+ Dom_val (rv) = dom;
+ CAMLreturn (rv);
+}
+
+static value
+Val_net (virNetworkPtr net)
+{
+ CAMLparam0 ();
+ CAMLlocal1 (rv);
+ rv = caml_alloc_custom (&net_custom_operations,
+ sizeof (virNetworkPtr), 0, 1);
+ Net_val (rv) = net;
+ CAMLreturn (rv);
+}
+
+static value
+Val_pol (virStoragePoolPtr pol)
+{
+ CAMLparam0 ();
+ CAMLlocal1 (rv);
+ rv = caml_alloc_custom (&pol_custom_operations,
+ sizeof (virStoragePoolPtr), 0, 1);
+ Pol_val (rv) = pol;
+ CAMLreturn (rv);
+}
+
+static value
+Val_vol (virStorageVolPtr vol)
+{
+ CAMLparam0 ();
+ CAMLlocal1 (rv);
+ rv = caml_alloc_custom (&vol_custom_operations,
+ sizeof (virStorageVolPtr), 0, 1);
+ Vol_val (rv) = vol;
+ CAMLreturn (rv);
+}
+
+static value
+Val_sec (virSecretPtr sec)
+{
+ CAMLparam0 ();
+ CAMLlocal1 (rv);
+ rv = caml_alloc_custom (&sec_custom_operations,
+ sizeof (virSecretPtr), 0, 1);
+ Sec_val (rv) = sec;
+ CAMLreturn (rv);
+}
+
+/* This wraps up the (dom, conn) pair (Domain.t). */
+static value
+Val_domain (virDomainPtr dom, value connv)
+{
+ CAMLparam1 (connv);
+ CAMLlocal2 (rv, v);
+
+ rv = caml_alloc_tuple (2);
+ v = Val_dom (dom);
+ Store_field (rv, 0, v);
+ Store_field (rv, 1, connv);
+ CAMLreturn (rv);
+}
+
+/* This wraps up the (net, conn) pair (Network.t). */
+static value
+Val_network (virNetworkPtr net, value connv)
+{
+ CAMLparam1 (connv);
+ CAMLlocal2 (rv, v);
+
+ rv = caml_alloc_tuple (2);
+ v = Val_net (net);
+ Store_field (rv, 0, v);
+ Store_field (rv, 1, connv);
+ CAMLreturn (rv);
+}
+
+/* This wraps up the (pol, conn) pair (Pool.t). */
+static value
+Val_pool (virStoragePoolPtr pol, value connv)
+{
+ CAMLparam1 (connv);
+ CAMLlocal2 (rv, v);
+
+ rv = caml_alloc_tuple (2);
+ v = Val_pol (pol);
+ Store_field (rv, 0, v);
+ Store_field (rv, 1, connv);
+ CAMLreturn (rv);
+}
+
+/* This wraps up the (vol, conn) pair (Volume.t). */
+static value
+Val_volume (virStorageVolPtr vol, value connv)
+{
+ CAMLparam1 (connv);
+ CAMLlocal2 (rv, v);
+
+ rv = caml_alloc_tuple (2);
+ v = Val_vol (vol);
+ Store_field (rv, 0, v);
+ Store_field (rv, 1, connv);
+ CAMLreturn (rv);
+}
+
+/* This wraps up the (sec, conn) pair (Secret.t). */
+static value
+Val_secret (virSecretPtr sec, value connv)
+{
+ CAMLparam1 (connv);
+ CAMLlocal2 (rv, v);
+
+ rv = caml_alloc_tuple (2);
+ v = Val_sec (sec);
+ Store_field (rv, 0, v);
+ Store_field (rv, 1, connv);
+ CAMLreturn (rv);
+}
+
+static void
+conn_finalize (value connv)
+{
+ virConnectPtr conn = Connect_val (connv);
+ if (conn) (void) virConnectClose (conn);
+}
+
+static void
+dom_finalize (value domv)
+{
+ virDomainPtr dom = Dom_val (domv);
+ if (dom) (void) virDomainFree (dom);
+}
+
+static void
+net_finalize (value netv)
+{
+ virNetworkPtr net = Net_val (netv);
+ if (net) (void) virNetworkFree (net);
+}
+
+static void
+pol_finalize (value polv)
+{
+ virStoragePoolPtr pol = Pol_val (polv);
+ if (pol) (void) virStoragePoolFree (pol);
+}
+
+static void
+vol_finalize (value volv)
+{
+ virStorageVolPtr vol = Vol_val (volv);
+ if (vol) (void) virStorageVolFree (vol);
+}
+
+static void
+sec_finalize (value secv)
+{
+ virSecretPtr sec = Sec_val (secv);
+ if (sec) (void) virSecretFree (sec);
+}
diff --git a/common/mllibvirt/libvirt_c_oneoffs.c
b/common/mllibvirt/libvirt_c_oneoffs.c
new file mode 100644
index 000000000..71ca78e98
--- /dev/null
+++ b/common/mllibvirt/libvirt_c_oneoffs.c
@@ -0,0 +1,1698 @@
+/* OCaml bindings for libvirt.
+ * (C) Copyright 2007-2017 Richard W.M. Jones, Red Hat Inc.
+ * https://libvirt.org/
+ *
+ * This library 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; either
+ * version 2 of the License, or (at your option) any later version.
+ *
+ * This library 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.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+ */
+
+/* Please read libvirt/README file. */
+
+#ifdef __GNUC__
+#pragma GCC diagnostic ignored "-Wmissing-prototypes"
+#endif
+
+/*----------------------------------------------------------------------*/
+
+CAMLprim value
+ocaml_libvirt_get_version (value driverv, value unit)
+{
+ CAMLparam2 (driverv, unit);
+ CAMLlocal1 (rv);
+ const char *driver = Optstring_val (driverv);
+ unsigned long libVer, typeVer = 0, *typeVer_ptr;
+ int r;
+
+ typeVer_ptr = driver ? &typeVer : NULL;
+ NONBLOCKING (r = virGetVersion (&libVer, driver, typeVer_ptr));
+ CHECK_ERROR (r == -1, "virGetVersion");
+
+ rv = caml_alloc_tuple (2);
+ Store_field (rv, 0, Val_int (libVer));
+ Store_field (rv, 1, Val_int (typeVer));
+ CAMLreturn (rv);
+}
+
+/*----------------------------------------------------------------------*/
+
+/* Connection object. */
+
+CAMLprim value
+ocaml_libvirt_connect_open (value namev, value unit)
+{
+ CAMLparam2 (namev, unit);
+ CAMLlocal1 (rv);
+ const char *name = Optstring_val (namev);
+ virConnectPtr conn;
+
+ NONBLOCKING (conn = virConnectOpen (name));
+ CHECK_ERROR (!conn, "virConnectOpen");
+
+ rv = Val_connect (conn);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_open_readonly (value namev, value unit)
+{
+ CAMLparam2 (namev, unit);
+ CAMLlocal1 (rv);
+ const char *name = Optstring_val (namev);
+ virConnectPtr conn;
+
+ NONBLOCKING (conn = virConnectOpenReadOnly (name));
+ CHECK_ERROR (!conn, "virConnectOpen");
+
+ rv = Val_connect (conn);
+
+ CAMLreturn (rv);
+}
+
+/* Helper struct holding data needed for the helper C authentication
+ * callback (which will call the actual OCaml callback).
+ */
+struct ocaml_auth_callback_data {
+ value *fvp; /* The OCaml auth callback. */
+};
+
+static int
+_ocaml_auth_callback (virConnectCredentialPtr cred, unsigned int ncred, void
*cbdata)
+{
+ CAMLparam0 ();
+ CAMLlocal4 (listv, elemv, rv, v);
+ struct ocaml_auth_callback_data *s = cbdata;
+ int i, len;
+
+ listv = Val_emptylist;
+ for (i = ncred - 1; i >= 0; --i) {
+ elemv = caml_alloc (2, 0);
+ Store_field (elemv, 0, Val_virconnectcredential (&cred[i]));
+ Store_field (elemv, 1, listv);
+ listv = elemv;
+ }
+
+ /* Call the auth callback. */
+ rv = caml_callback_exn (*s->fvp, listv);
+ if (Is_exception_result (rv)) {
+ /* The callback raised an exception, so return an error. */
+ CAMLreturnT (int, -1);
+ }
+
+ len = _list_length (rv);
+ if (len != (int) ncred) {
+ /* The callback did not return the same number of results as the
+ * credentials.
+ */
+ CAMLreturnT (int, -1);
+ }
+
+ for (i = 0; rv != Val_emptylist; rv = Field (rv, 1), ++i) {
+ virConnectCredentialPtr c = &cred[i];
+ elemv = Field (rv, 0);
+ if (elemv == Val_int (0)) {
+ c->result = NULL;
+ c->resultlen = 0;
+ } else {
+ v = Field (elemv, 0);
+ len = caml_string_length (v);
+ c->result = malloc (len + 1);
+ if (c->result == NULL)
+ CAMLreturnT (int, -1);
+ memcpy (c->result, String_val (v), len);
+ c->result[len] = '\0';
+ c->resultlen = len;
+ }
+ }
+
+ CAMLreturnT (int, 0);
+}
+
+static virConnectPtr
+_ocaml_libvirt_connect_open_auth_common (value namev, value authv, int flags)
+{
+ CAMLparam2 (namev, authv);
+ CAMLlocal2 (listv, fv);
+ virConnectPtr conn;
+ virConnectAuth auth;
+ struct ocaml_auth_callback_data data;
+ int i;
+ char *name = NULL;
+
+ /* Keep a copy of the 'namev' string, as its value could move around
+ * when calling other OCaml code that allocates memory.
+ */
+ if (namev != Val_int (0)) { /* Some string */
+ name = strdup (String_val (Field (namev, 0)));
+ if (name == NULL)
+ caml_raise_out_of_memory ();
+ }
+
+ fv = Field (authv, 1);
+ data.fvp = &fv;
+
+ listv = Field (authv, 0);
+ auth.ncredtype = _list_length (listv);
+ auth.credtype = malloc (sizeof (int) * auth.ncredtype);
+ if (auth.credtype == NULL)
+ caml_raise_out_of_memory ();
+ for (i = 0; listv != Val_emptylist; listv = Field (listv, 1), ++i) {
+ auth.credtype[i] = Int_val (Field (listv, 0)) + 1;
+ }
+ auth.cb = &_ocaml_auth_callback;
+ auth.cbdata = &data;
+
+ /* Call virConnectOpenAuth directly, without using the NONBLOCKING
+ * macro, as this will indeed call ocaml_* APIs, and run OCaml code.
+ */
+ conn = virConnectOpenAuth (name, &auth, flags);
+ free (auth.credtype);
+ free (name);
+ CHECK_ERROR (!conn, "virConnectOpenAuth");
+
+ CAMLreturnT (virConnectPtr, conn);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_open_auth (value namev, value authv)
+{
+ CAMLparam2 (namev, authv);
+ CAMLlocal1 (rv);
+ virConnectPtr conn;
+
+ conn = _ocaml_libvirt_connect_open_auth_common (namev, authv, 0);
+ rv = Val_connect (conn);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_open_auth_readonly (value namev, value authv)
+{
+ CAMLparam2 (namev, authv);
+ CAMLlocal1 (rv);
+ virConnectPtr conn;
+
+ conn = _ocaml_libvirt_connect_open_auth_common (namev, authv,
VIR_CONNECT_RO);
+ rv = Val_connect (conn);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_get_version (value connv)
+{
+ CAMLparam1 (connv);
+ virConnectPtr conn = Connect_val (connv);
+ unsigned long hvVer;
+ int r;
+
+ NONBLOCKING (r = virConnectGetVersion (conn, &hvVer));
+ CHECK_ERROR (r == -1, "virConnectGetVersion");
+
+ CAMLreturn (Val_int (hvVer));
+}
+
+CAMLprim value
+ocaml_libvirt_connect_get_max_vcpus (value connv, value typev)
+{
+ CAMLparam2 (connv, typev);
+ virConnectPtr conn = Connect_val (connv);
+ const char *type = Optstring_val (typev);
+ int r;
+
+ NONBLOCKING (r = virConnectGetMaxVcpus (conn, type));
+ CHECK_ERROR (r == -1, "virConnectGetMaxVcpus");
+
+ CAMLreturn (Val_int (r));
+}
+
+CAMLprim value
+ocaml_libvirt_connect_get_node_info (value connv)
+{
+ CAMLparam1 (connv);
+ CAMLlocal2 (rv, v);
+ virConnectPtr conn = Connect_val (connv);
+ virNodeInfo info;
+ int r;
+
+ NONBLOCKING (r = virNodeGetInfo (conn, &info));
+ CHECK_ERROR (r == -1, "virNodeGetInfo");
+
+ rv = caml_alloc (8, 0);
+ v = caml_copy_string (info.model); Store_field (rv, 0, v);
+ v = caml_copy_int64 (info.memory); Store_field (rv, 1, v);
+ Store_field (rv, 2, Val_int (info.cpus));
+ Store_field (rv, 3, Val_int (info.mhz));
+ Store_field (rv, 4, Val_int (info.nodes));
+ Store_field (rv, 5, Val_int (info.sockets));
+ Store_field (rv, 6, Val_int (info.cores));
+ Store_field (rv, 7, Val_int (info.threads));
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_node_get_free_memory (value connv)
+{
+ CAMLparam1 (connv);
+ CAMLlocal1 (rv);
+ virConnectPtr conn = Connect_val (connv);
+ unsigned long long r;
+
+ NONBLOCKING (r = virNodeGetFreeMemory (conn));
+ CHECK_ERROR (r == 0, "virNodeGetFreeMemory");
+
+ rv = caml_copy_int64 ((int64_t) r);
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_node_get_cells_free_memory (value connv,
+ value startv, value maxv)
+{
+ CAMLparam3 (connv, startv, maxv);
+ CAMLlocal2 (rv, iv);
+ virConnectPtr conn = Connect_val (connv);
+ int start = Int_val (startv);
+ int max = Int_val (maxv);
+ int r, i;
+ unsigned long long *freemems;
+
+ freemems = malloc(sizeof (*freemems) * max);
+ if (freemems == NULL)
+ caml_raise_out_of_memory ();
+
+ NONBLOCKING (r = virNodeGetCellsFreeMemory (conn, freemems, start, max));
+ CHECK_ERROR_CLEANUP (r == -1, free (freemems),
"virNodeGetCellsFreeMemory");
+
+ rv = caml_alloc (r, 0);
+ for (i = 0; i < r; ++i) {
+ iv = caml_copy_int64 ((int64_t) freemems[i]);
+ Store_field (rv, i, iv);
+ }
+ free (freemems);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_set_keep_alive(value connv,
+ value intervalv, value countv)
+{
+ CAMLparam3 (connv, intervalv, countv);
+ virConnectPtr conn = Connect_val(connv);
+ int interval = Int_val(intervalv);
+ unsigned int count = Int_val(countv);
+ int r;
+
+ NONBLOCKING(r = virConnectSetKeepAlive(conn, interval, count));
+ CHECK_ERROR (r == -1, "virConnectSetKeepAlive");
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_credtypes_from_auth_default (value unitv)
+{
+ CAMLparam1 (unitv);
+ CAMLlocal2 (listv, itemv);
+ int i;
+
+ listv = Val_emptylist;
+
+ if (virConnectAuthPtrDefault) {
+ for (i = virConnectAuthPtrDefault->ncredtype; i >= 0; --i) {
+ const int type = virConnectAuthPtrDefault->credtype[i];
+ itemv = caml_alloc (2, 0);
+ Store_field (itemv, 0, Val_int (type - 1));
+ Store_field (itemv, 1, listv);
+ listv = itemv;
+ }
+ }
+
+ CAMLreturn (listv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_call_auth_default_callback (value listv)
+{
+ CAMLparam1 (listv);
+ CAMLlocal5 (credv, retv, elemv, optv, v);
+ int i, len, ret;
+ const char *str;
+ virConnectCredentialPtr creds;
+
+ if (virConnectAuthPtrDefault == NULL
+ || virConnectAuthPtrDefault->cb == NULL)
+ CAMLreturn (Val_unit);
+
+ len = _list_length (listv);
+ creds = calloc (len, sizeof (*creds));
+ if (creds == NULL)
+ caml_raise_out_of_memory ();
+ for (i = 0; listv != Val_emptylist; listv = Field (listv, 1), ++i) {
+ virConnectCredentialPtr cred = &creds[i];
+ credv = Field (listv, 0);
+ cred->type = Int_val (Field (credv, 0)) + 1;
+ cred->prompt = strdup (String_val (Field (credv, 1)));
+ if (cred->prompt == NULL)
+ caml_raise_out_of_memory ();
+ str = Optstring_val (Field (credv, 2));
+ if (str) {
+ cred->challenge = strdup (str);
+ if (cred->challenge == NULL)
+ caml_raise_out_of_memory ();
+ }
+ str = Optstring_val (Field (credv, 3));
+ if (str) {
+ cred->defresult = strdup (str);
+ if (cred->defresult == NULL)
+ caml_raise_out_of_memory ();
+ }
+ }
+
+ ret = virConnectAuthPtrDefault->cb (creds, len,
+ virConnectAuthPtrDefault->cbdata);
+ if (ret >= 0) {
+ retv = Val_emptylist;
+ for (i = len - 1; i >= 0; --i) {
+ virConnectCredentialPtr cred = &creds[i];
+ elemv = caml_alloc (2, 0);
+ if (cred->result != NULL && cred->resultlen > 0) {
+ v = caml_alloc_string (cred->resultlen);
+ memcpy (String_val (v), cred->result, cred->resultlen);
+ optv = caml_alloc (1, 0);
+ Store_field (optv, 0, v);
+ } else
+ optv = Val_int (0);
+ Store_field (elemv, 0, optv);
+ Store_field (elemv, 1, retv);
+ retv = elemv;
+ }
+ }
+ for (i = 0; i < len; ++i) {
+ virConnectCredentialPtr cred = &creds[i];
+ /* Cast to char *, as the virConnectCredential structs we fill have
+ * const char * qualifiers.
+ */
+ free ((char *) cred->prompt);
+ free ((char *) cred->challenge);
+ free ((char *) cred->defresult);
+ }
+ free (creds);
+
+ if (ret < 0)
+ caml_failwith ("virConnectAuthPtrDefault callback failed");
+
+ CAMLreturn (retv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_get_id (value domv)
+{
+ CAMLparam1 (domv);
+ virDomainPtr dom = Domain_val (domv);
+ unsigned int r;
+
+ NONBLOCKING (r = virDomainGetID (dom));
+ /* In theory this could return -1 on error, but in practice
+ * libvirt never does this unless you call it with a corrupted
+ * or NULL dom object. So ignore errors here.
+ */
+
+ CAMLreturn (Val_int ((int) r));
+}
+
+CAMLprim value
+ocaml_libvirt_domain_get_max_memory (value domv)
+{
+ CAMLparam1 (domv);
+ CAMLlocal1 (rv);
+ virDomainPtr dom = Domain_val (domv);
+ unsigned long r;
+
+ NONBLOCKING (r = virDomainGetMaxMemory (dom));
+ CHECK_ERROR (r == 0 /* [sic] */, "virDomainGetMaxMemory");
+
+ rv = caml_copy_int64 (r);
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_set_max_memory (value domv, value memv)
+{
+ CAMLparam2 (domv, memv);
+ virDomainPtr dom = Domain_val (domv);
+ unsigned long mem = Int64_val (memv);
+ int r;
+
+ NONBLOCKING (r = virDomainSetMaxMemory (dom, mem));
+ CHECK_ERROR (r == -1, "virDomainSetMaxMemory");
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_set_memory (value domv, value memv)
+{
+ CAMLparam2 (domv, memv);
+ virDomainPtr dom = Domain_val (domv);
+ unsigned long mem = Int64_val (memv);
+ int r;
+
+ NONBLOCKING (r = virDomainSetMemory (dom, mem));
+ CHECK_ERROR (r == -1, "virDomainSetMemory");
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_get_info (value domv)
+{
+ CAMLparam1 (domv);
+ CAMLlocal2 (rv, v);
+ virDomainPtr dom = Domain_val (domv);
+ virDomainInfo info;
+ int r;
+
+ NONBLOCKING (r = virDomainGetInfo (dom, &info));
+ CHECK_ERROR (r == -1, "virDomainGetInfo");
+
+ rv = caml_alloc (5, 0);
+ Store_field (rv, 0, Val_int (info.state)); // These flags are compatible.
+ v = caml_copy_int64 (info.maxMem); Store_field (rv, 1, v);
+ v = caml_copy_int64 (info.memory); Store_field (rv, 2, v);
+ Store_field (rv, 3, Val_int (info.nrVirtCpu));
+ v = caml_copy_int64 (info.cpuTime); Store_field (rv, 4, v);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_get_scheduler_type (value domv)
+{
+ CAMLparam1 (domv);
+ CAMLlocal2 (rv, strv);
+ virDomainPtr dom = Domain_val (domv);
+ char *r;
+ int nparams;
+
+ NONBLOCKING (r = virDomainGetSchedulerType (dom, &nparams));
+ CHECK_ERROR (!r, "virDomainGetSchedulerType");
+
+ rv = caml_alloc_tuple (2);
+ strv = caml_copy_string (r); Store_field (rv, 0, strv);
+ free (r);
+ Store_field (rv, 1, nparams);
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_get_scheduler_parameters (value domv, value nparamsv)
+{
+ CAMLparam2 (domv, nparamsv);
+ CAMLlocal4 (rv, v, v2, v3);
+ virDomainPtr dom = Domain_val (domv);
+ int nparams = Int_val (nparamsv);
+ virSchedParameterPtr params;
+ int r, i;
+
+ params = malloc (sizeof (*params) * nparams);
+ if (params == NULL)
+ caml_raise_out_of_memory ();
+
+ NONBLOCKING (r = virDomainGetSchedulerParameters (dom, params,
&nparams));
+ CHECK_ERROR_CLEANUP (r == -1, free (params),
"virDomainGetSchedulerParameters");
+
+ rv = caml_alloc (nparams, 0);
+ for (i = 0; i < nparams; ++i) {
+ v = caml_alloc_tuple (2); Store_field (rv, i, v);
+ v2 = caml_copy_string (params[i].field); Store_field (v, 0, v2);
+ switch (params[i].type) {
+ case VIR_DOMAIN_SCHED_FIELD_INT:
+ v2 = caml_alloc (1, 0);
+ v3 = caml_copy_int32 (params[i].value.i); Store_field (v2, 0, v3);
+ break;
+ case VIR_DOMAIN_SCHED_FIELD_UINT:
+ v2 = caml_alloc (1, 1);
+ v3 = caml_copy_int32 (params[i].value.ui); Store_field (v2, 0, v3);
+ break;
+ case VIR_DOMAIN_SCHED_FIELD_LLONG:
+ v2 = caml_alloc (1, 2);
+ v3 = caml_copy_int64 (params[i].value.l); Store_field (v2, 0, v3);
+ break;
+ case VIR_DOMAIN_SCHED_FIELD_ULLONG:
+ v2 = caml_alloc (1, 3);
+ v3 = caml_copy_int64 (params[i].value.ul); Store_field (v2, 0, v3);
+ break;
+ case VIR_DOMAIN_SCHED_FIELD_DOUBLE:
+ v2 = caml_alloc (1, 4);
+ v3 = caml_copy_double (params[i].value.d); Store_field (v2, 0, v3);
+ break;
+ case VIR_DOMAIN_SCHED_FIELD_BOOLEAN:
+ v2 = caml_alloc (1, 5);
+ Store_field (v2, 0, Val_int (params[i].value.b));
+ break;
+ default:
+ caml_failwith ((char *)__FUNCTION__);
+ }
+ Store_field (v, 1, v2);
+ }
+ free (params);
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_set_scheduler_parameters (value domv, value paramsv)
+{
+ CAMLparam2 (domv, paramsv);
+ CAMLlocal1 (v);
+ virDomainPtr dom = Domain_val (domv);
+ int nparams = Wosize_val (paramsv);
+ virSchedParameterPtr params;
+ int r, i;
+ char *name;
+
+ params = malloc (sizeof (*params) * nparams);
+ if (params == NULL)
+ caml_raise_out_of_memory ();
+
+ for (i = 0; i < nparams; ++i) {
+ v = Field (paramsv, i); /* Points to the two-element tuple. */
+ name = String_val (Field (v, 0));
+ strncpy (params[i].field, name, VIR_DOMAIN_SCHED_FIELD_LENGTH);
+ params[i].field[VIR_DOMAIN_SCHED_FIELD_LENGTH-1] = '\0';
+ v = Field (v, 1); /* Points to the sched_param_value block. */
+ switch (Tag_val (v)) {
+ case 0:
+ params[i].type = VIR_DOMAIN_SCHED_FIELD_INT;
+ params[i].value.i = Int32_val (Field (v, 0));
+ break;
+ case 1:
+ params[i].type = VIR_DOMAIN_SCHED_FIELD_UINT;
+ params[i].value.ui = Int32_val (Field (v, 0));
+ break;
+ case 2:
+ params[i].type = VIR_DOMAIN_SCHED_FIELD_LLONG;
+ params[i].value.l = Int64_val (Field (v, 0));
+ break;
+ case 3:
+ params[i].type = VIR_DOMAIN_SCHED_FIELD_ULLONG;
+ params[i].value.ul = Int64_val (Field (v, 0));
+ break;
+ case 4:
+ params[i].type = VIR_DOMAIN_SCHED_FIELD_DOUBLE;
+ params[i].value.d = Double_val (Field (v, 0));
+ break;
+ case 5:
+ params[i].type = VIR_DOMAIN_SCHED_FIELD_BOOLEAN;
+ params[i].value.b = Int_val (Field (v, 0));
+ break;
+ default:
+ caml_failwith ((char *)__FUNCTION__);
+ }
+ }
+
+ NONBLOCKING (r = virDomainSetSchedulerParameters (dom, params, nparams));
+ free (params);
+ CHECK_ERROR (r == -1, "virDomainSetSchedulerParameters");
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_set_vcpus (value domv, value nvcpusv)
+{
+ CAMLparam2 (domv, nvcpusv);
+ virDomainPtr dom = Domain_val (domv);
+ int r, nvcpus = Int_val (nvcpusv);
+
+ NONBLOCKING (r = virDomainSetVcpus (dom, nvcpus));
+ CHECK_ERROR (r == -1, "virDomainSetVcpus");
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_pin_vcpu (value domv, value vcpuv, value cpumapv)
+{
+ CAMLparam3 (domv, vcpuv, cpumapv);
+ virDomainPtr dom = Domain_val (domv);
+ int maplen = caml_string_length (cpumapv);
+ unsigned char *cpumap = (unsigned char *) String_val (cpumapv);
+ int vcpu = Int_val (vcpuv);
+ int r;
+
+ NONBLOCKING (r = virDomainPinVcpu (dom, vcpu, cpumap, maplen));
+ CHECK_ERROR (r == -1, "virDomainPinVcpu");
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_get_vcpus (value domv, value maxinfov, value maplenv)
+{
+ CAMLparam3 (domv, maxinfov, maplenv);
+ CAMLlocal5 (rv, infov, strv, v, v2);
+ virDomainPtr dom = Domain_val (domv);
+ int maxinfo = Int_val (maxinfov);
+ int maplen = Int_val (maplenv);
+ virVcpuInfoPtr info;
+ unsigned char *cpumaps;
+ int r, i;
+
+ info = calloc (maxinfo, sizeof (*info));
+ if (info == NULL)
+ caml_raise_out_of_memory ();
+ cpumaps = calloc (maxinfo * maplen, sizeof (*cpumaps));
+ if (cpumaps == NULL) {
+ free (info);
+ caml_raise_out_of_memory ();
+ }
+
+ NONBLOCKING (r = virDomainGetVcpus (dom, info, maxinfo, cpumaps, maplen));
+ CHECK_ERROR_CLEANUP (r == -1, free (info); free (cpumaps),
"virDomainPinVcpu");
+
+ /* Copy the virVcpuInfo structures. */
+ infov = caml_alloc (maxinfo, 0);
+ for (i = 0; i < maxinfo; ++i) {
+ v2 = caml_alloc (4, 0); Store_field (infov, i, v2);
+ Store_field (v2, 0, Val_int (info[i].number));
+ Store_field (v2, 1, Val_int (info[i].state));
+ v = caml_copy_int64 (info[i].cpuTime); Store_field (v2, 2, v);
+ Store_field (v2, 3, Val_int (info[i].cpu));
+ }
+
+ /* Copy the bitmap. */
+ strv = caml_alloc_string (maxinfo * maplen);
+ memcpy (String_val (strv), cpumaps, maxinfo * maplen);
+
+ /* Allocate the tuple and return it. */
+ rv = caml_alloc_tuple (3);
+ Store_field (rv, 0, Val_int (r)); /* number of CPUs. */
+ Store_field (rv, 1, infov);
+ Store_field (rv, 2, strv);
+
+ free (info);
+ free (cpumaps);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_get_cpu_stats (value domv)
+{
+ CAMLparam1 (domv);
+ CAMLlocal5 (cpustats, param_head, param_node, typed_param,
typed_param_value);
+ CAMLlocal1 (v);
+ virDomainPtr dom = Domain_val (domv);
+ virTypedParameterPtr params;
+ int r, cpu, ncpus, nparams, i, j, pos;
+ int nr_pcpus;
+
+ /* get number of pcpus */
+ NONBLOCKING (nr_pcpus = virDomainGetCPUStats(dom, NULL, 0, 0, 0, 0));
+ CHECK_ERROR (nr_pcpus < 0, "virDomainGetCPUStats");
+
+ /* get percpu information */
+ NONBLOCKING (nparams = virDomainGetCPUStats(dom, NULL, 0, 0, 1, 0));
+ CHECK_ERROR (nparams < 0, "virDomainGetCPUStats");
+
+ if ((params = malloc(sizeof(*params) * nparams * 128)) == NULL)
+ caml_failwith ("virDomainGetCPUStats: malloc");
+
+ cpustats = caml_alloc (nr_pcpus, 0); /* cpustats: array of params(list of
typed_param) */
+ cpu = 0;
+ while (cpu < nr_pcpus) {
+ ncpus = nr_pcpus - cpu > 128 ? 128 : nr_pcpus - cpu;
+
+ NONBLOCKING (r = virDomainGetCPUStats(dom, params, nparams, cpu, ncpus,
0));
+ CHECK_ERROR (r < 0, "virDomainGetCPUStats");
+
+ for (i = 0; i < ncpus; i++) {
+ /* list of typed_param: single linked list of param_nodes */
+ param_head = Val_emptylist; /* param_head: the head param_node of list of
typed_param */
+
+ if (params[i * nparams].type == 0) {
+ Store_field(cpustats, cpu + i, param_head);
+ continue;
+ }
+
+ for (j = r - 1; j >= 0; j--) {
+ pos = i * nparams + j;
+ if (params[pos].type == 0)
+ continue;
+
+ param_node = caml_alloc(2, 0); /* param_node: typed_param, next
param_node */
+ Store_field(param_node, 1, param_head);
+ param_head = param_node;
+
+ typed_param = caml_alloc(2, 0); /* typed_param: field name(string),
typed_param_value */
+ Store_field(param_node, 0, typed_param);
+ Store_field(typed_param, 0, caml_copy_string(params[pos].field));
+
+ /* typed_param_value: value with the corresponding type tag */
+ switch(params[pos].type) {
+ case VIR_TYPED_PARAM_INT:
+ typed_param_value = caml_alloc (1, 0);
+ v = caml_copy_int32 (params[pos].value.i);
+ break;
+ case VIR_TYPED_PARAM_UINT:
+ typed_param_value = caml_alloc (1, 1);
+ v = caml_copy_int32 (params[pos].value.ui);
+ break;
+ case VIR_TYPED_PARAM_LLONG:
+ typed_param_value = caml_alloc (1, 2);
+ v = caml_copy_int64 (params[pos].value.l);
+ break;
+ case VIR_TYPED_PARAM_ULLONG:
+ typed_param_value = caml_alloc (1, 3);
+ v = caml_copy_int64 (params[pos].value.ul);
+ break;
+ case VIR_TYPED_PARAM_DOUBLE:
+ typed_param_value = caml_alloc (1, 4);
+ v = caml_copy_double (params[pos].value.d);
+ break;
+ case VIR_TYPED_PARAM_BOOLEAN:
+ typed_param_value = caml_alloc (1, 5);
+ v = Val_bool (params[pos].value.b);
+ break;
+ case VIR_TYPED_PARAM_STRING:
+ typed_param_value = caml_alloc (1, 6);
+ v = caml_copy_string (params[pos].value.s);
+ free (params[pos].value.s);
+ break;
+ default:
+ /* XXX Memory leak on this path, if there are more
+ * VIR_TYPED_PARAM_STRING past this point in the array.
+ */
+ free (params);
+ caml_failwith ("virDomainGetCPUStats: "
+ "unknown parameter type returned");
+ }
+ Store_field (typed_param_value, 0, v);
+ Store_field (typed_param, 1, typed_param_value);
+ }
+ Store_field (cpustats, cpu + i, param_head);
+ }
+ cpu += ncpus;
+ }
+ free(params);
+ CAMLreturn (cpustats);
+}
+
+value
+ocaml_libvirt_domain_get_all_domain_stats (value connv,
+ value statsv, value flagsv)
+{
+ CAMLparam3 (connv, statsv, flagsv);
+ CAMLlocal5 (rv, dsv, tpv, v, v1);
+ CAMLlocal1 (v2);
+ virConnectPtr conn = Connect_val (connv);
+ virDomainStatsRecordPtr *rstats;
+ unsigned int stats = 0, flags = 0;
+ int i, j, r;
+ unsigned char uuid[VIR_UUID_BUFLEN];
+
+ /* Get stats and flags. */
+ for (; statsv != Val_int (0); statsv = Field (statsv, 1)) {
+ v = Field (statsv, 0);
+ if (v == Val_int (0))
+ stats |= VIR_DOMAIN_STATS_STATE;
+ else if (v == Val_int (1))
+ stats |= VIR_DOMAIN_STATS_CPU_TOTAL;
+ else if (v == Val_int (2))
+ stats |= VIR_DOMAIN_STATS_BALLOON;
+ else if (v == Val_int (3))
+ stats |= VIR_DOMAIN_STATS_VCPU;
+ else if (v == Val_int (4))
+ stats |= VIR_DOMAIN_STATS_INTERFACE;
+ else if (v == Val_int (5))
+ stats |= VIR_DOMAIN_STATS_BLOCK;
+ else if (v == Val_int (6))
+ stats |= VIR_DOMAIN_STATS_PERF;
+ }
+ for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1)) {
+ v = Field (flagsv, 0);
+ if (v == Val_int (0))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_ACTIVE;
+ else if (v == Val_int (1))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_INACTIVE;
+ else if (v == Val_int (2))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_OTHER;
+ else if (v == Val_int (3))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_PAUSED;
+ else if (v == Val_int (4))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_PERSISTENT;
+ else if (v == Val_int (5))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_RUNNING;
+ else if (v == Val_int (6))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_SHUTOFF;
+ else if (v == Val_int (7))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_TRANSIENT;
+ else if (v == Val_int (8))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_BACKING;
+ else if (v == Val_int (9))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_ENFORCE_STATS;
+ }
+
+ NONBLOCKING (r = virConnectGetAllDomainStats (conn, stats, &rstats,
flags));
+ CHECK_ERROR (r == -1, "virConnectGetAllDomainStats");
+
+ rv = caml_alloc (r, 0); /* domain_stats_record array. */
+ for (i = 0; i < r; ++i) {
+ dsv = caml_alloc (2, 0); /* domain_stats_record */
+
+ /* Libvirt returns something superficially resembling a
+ * virDomainPtr, but it's not a real virDomainPtr object
+ * (eg. dom->id == -1, and its refcount is wrong). The only thing
+ * we can safely get from it is the UUID.
+ */
+ v = caml_alloc_string (VIR_UUID_BUFLEN);
+ virDomainGetUUID (rstats[i]->dom, uuid);
+ memcpy (String_val (v), uuid, VIR_UUID_BUFLEN);
+ Store_field (dsv, 0, v);
+
+ tpv = caml_alloc (rstats[i]->nparams, 0); /* typed_param array */
+ for (j = 0; j < rstats[i]->nparams; ++j) {
+ v2 = caml_alloc (2, 0); /* typed_param: field name, value */
+ Store_field (v2, 0, caml_copy_string (rstats[i]->params[j].field));
+
+ switch (rstats[i]->params[j].type) {
+ case VIR_TYPED_PARAM_INT:
+ v1 = caml_alloc (1, 0);
+ v = caml_copy_int32 (rstats[i]->params[j].value.i);
+ break;
+ case VIR_TYPED_PARAM_UINT:
+ v1 = caml_alloc (1, 1);
+ v = caml_copy_int32 (rstats[i]->params[j].value.ui);
+ break;
+ case VIR_TYPED_PARAM_LLONG:
+ v1 = caml_alloc (1, 2);
+ v = caml_copy_int64 (rstats[i]->params[j].value.l);
+ break;
+ case VIR_TYPED_PARAM_ULLONG:
+ v1 = caml_alloc (1, 3);
+ v = caml_copy_int64 (rstats[i]->params[j].value.ul);
+ break;
+ case VIR_TYPED_PARAM_DOUBLE:
+ v1 = caml_alloc (1, 4);
+ v = caml_copy_double (rstats[i]->params[j].value.d);
+ break;
+ case VIR_TYPED_PARAM_BOOLEAN:
+ v1 = caml_alloc (1, 5);
+ v = Val_bool (rstats[i]->params[j].value.b);
+ break;
+ case VIR_TYPED_PARAM_STRING:
+ v1 = caml_alloc (1, 6);
+ v = caml_copy_string (rstats[i]->params[j].value.s);
+ break;
+ default:
+ virDomainStatsRecordListFree (rstats);
+ caml_failwith ("virConnectGetAllDomainStats: "
+ "unknown parameter type returned");
+ }
+ Store_field (v1, 0, v);
+
+ Store_field (v2, 1, v1);
+ Store_field (tpv, j, v2);
+ }
+
+ Store_field (dsv, 1, tpv);
+ Store_field (rv, i, dsv);
+ }
+
+ virDomainStatsRecordListFree (rstats);
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_migrate_native (value domv, value dconnv, value flagsv,
value optdnamev, value opturiv, value optbandwidthv, value unitv)
+{
+ CAMLparam5 (domv, dconnv, flagsv, optdnamev, opturiv);
+ CAMLxparam2 (optbandwidthv, unitv);
+ CAMLlocal2 (flagv, rv);
+ virDomainPtr dom = Domain_val (domv);
+ virConnectPtr dconn = Connect_val (dconnv);
+ int flags = 0;
+ const char *dname = Optstring_val (optdnamev);
+ const char *uri = Optstring_val (opturiv);
+ unsigned long bandwidth;
+ virDomainPtr r;
+
+ /* Iterate over the list of flags. */
+ for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1))
+ {
+ flagv = Field (flagsv, 0);
+ if (flagv == Val_int (0))
+ flags |= VIR_MIGRATE_LIVE;
+ }
+
+ if (optbandwidthv == Val_int (0)) /* None */
+ bandwidth = 0;
+ else /* Some bandwidth */
+ bandwidth = Int_val (Field (optbandwidthv, 0));
+
+ NONBLOCKING (r = virDomainMigrate (dom, dconn, flags, dname, uri,
bandwidth));
+ CHECK_ERROR (!r, "virDomainMigrate");
+
+ rv = Val_domain (r, dconnv);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_migrate_bytecode (value *argv, int argn)
+{
+ return ocaml_libvirt_domain_migrate_native (argv[0], argv[1], argv[2],
+ argv[3], argv[4], argv[5],
+ argv[6]);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_block_stats (value domv, value pathv)
+{
+ CAMLparam2 (domv, pathv);
+ CAMLlocal2 (rv,v);
+ virDomainPtr dom = Domain_val (domv);
+ char *path = String_val (pathv);
+ struct _virDomainBlockStats stats;
+ int r;
+
+ NONBLOCKING (r = virDomainBlockStats (dom, path, &stats, sizeof stats));
+ CHECK_ERROR (r == -1, "virDomainBlockStats");
+
+ rv = caml_alloc (5, 0);
+ v = caml_copy_int64 (stats.rd_req); Store_field (rv, 0, v);
+ v = caml_copy_int64 (stats.rd_bytes); Store_field (rv, 1, v);
+ v = caml_copy_int64 (stats.wr_req); Store_field (rv, 2, v);
+ v = caml_copy_int64 (stats.wr_bytes); Store_field (rv, 3, v);
+ v = caml_copy_int64 (stats.errs); Store_field (rv, 4, v);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_interface_stats (value domv, value pathv)
+{
+ CAMLparam2 (domv, pathv);
+ CAMLlocal2 (rv,v);
+ virDomainPtr dom = Domain_val (domv);
+ char *path = String_val (pathv);
+ struct _virDomainInterfaceStats stats;
+ int r;
+
+ NONBLOCKING (r = virDomainInterfaceStats (dom, path, &stats, sizeof
stats));
+ CHECK_ERROR (r == -1, "virDomainInterfaceStats");
+
+ rv = caml_alloc (8, 0);
+ v = caml_copy_int64 (stats.rx_bytes); Store_field (rv, 0, v);
+ v = caml_copy_int64 (stats.rx_packets); Store_field (rv, 1, v);
+ v = caml_copy_int64 (stats.rx_errs); Store_field (rv, 2, v);
+ v = caml_copy_int64 (stats.rx_drop); Store_field (rv, 3, v);
+ v = caml_copy_int64 (stats.tx_bytes); Store_field (rv, 4, v);
+ v = caml_copy_int64 (stats.tx_packets); Store_field (rv, 5, v);
+ v = caml_copy_int64 (stats.tx_errs); Store_field (rv, 6, v);
+ v = caml_copy_int64 (stats.tx_drop); Store_field (rv, 7, v);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_block_peek_native (value domv, value pathv, value offsetv,
value sizev, value bufferv, value boffv)
+{
+ CAMLparam5 (domv, pathv, offsetv, sizev, bufferv);
+ CAMLxparam1 (boffv);
+ virDomainPtr dom = Domain_val (domv);
+ const char *path = String_val (pathv);
+ unsigned long long offset = Int64_val (offsetv);
+ size_t size = Int_val (sizev);
+ char *buffer = String_val (bufferv);
+ int boff = Int_val (boffv);
+ int r;
+
+ /* Check that the return buffer is big enough. */
+ if (caml_string_length (bufferv) < boff + size)
+ caml_failwith ("virDomainBlockPeek: return buffer too short");
+
+ /* NB. not NONBLOCKING because buffer might move (XXX) */
+ r = virDomainBlockPeek (dom, path, offset, size, buffer+boff, 0);
+ CHECK_ERROR (r == -1, "virDomainBlockPeek");
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_block_peek_bytecode (value *argv, int argn)
+{
+ return ocaml_libvirt_domain_block_peek_native (argv[0], argv[1], argv[2],
+ argv[3], argv[4], argv[5]);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_memory_peek_native (value domv, value flagsv, value
offsetv, value sizev, value bufferv, value boffv)
+{
+ CAMLparam5 (domv, flagsv, offsetv, sizev, bufferv);
+ CAMLxparam1 (boffv);
+ CAMLlocal1 (flagv);
+ virDomainPtr dom = Domain_val (domv);
+ int flags = 0;
+ unsigned long long offset = Int64_val (offsetv);
+ size_t size = Int_val (sizev);
+ char *buffer = String_val (bufferv);
+ int boff = Int_val (boffv);
+ int r;
+
+ /* Check that the return buffer is big enough. */
+ if (caml_string_length (bufferv) < boff + size)
+ caml_failwith ("virDomainMemoryPeek: return buffer too short");
+
+ /* Do flags. */
+ for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1))
+ {
+ flagv = Field (flagsv, 0);
+ if (flagv == Val_int (0))
+ flags |= VIR_MEMORY_VIRTUAL;
+ }
+
+ /* NB. not NONBLOCKING because buffer might move (XXX) */
+ r = virDomainMemoryPeek (dom, offset, size, buffer+boff, flags);
+ CHECK_ERROR (r == -1, "virDomainMemoryPeek");
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_memory_peek_bytecode (value *argv, int argn)
+{
+ return ocaml_libvirt_domain_memory_peek_native (argv[0], argv[1], argv[2],
+ argv[3], argv[4], argv[5]);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_get_xml_desc_flags (value domv, value flagsv)
+{
+ CAMLparam2 (domv, flagsv);
+ CAMLlocal2 (rv, flagv);
+ virDomainPtr dom = Domain_val (domv);
+ int flags = 0;
+ char *r;
+
+ /* Do flags. */
+ for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1))
+ {
+ flagv = Field (flagsv, 0);
+ if (flagv == Val_int (0))
+ flags |= VIR_DOMAIN_XML_SECURE;
+ else if (flagv == Val_int (1))
+ flags |= VIR_DOMAIN_XML_INACTIVE;
+ else if (flagv == Val_int (2))
+ flags |= VIR_DOMAIN_XML_UPDATE_CPU;
+ else if (flagv == Val_int (3))
+ flags |= VIR_DOMAIN_XML_MIGRATABLE;
+ }
+
+ NONBLOCKING (r = virDomainGetXMLDesc (dom, flags));
+ CHECK_ERROR (!r, "virDomainGetXMLDesc");
+
+ rv = caml_copy_string (r);
+ free (r);
+ CAMLreturn (rv);
+}
+
+/*----------------------------------------------------------------------*/
+
+/* Domain events */
+
+CAMLprim value
+ocaml_libvirt_event_register_default_impl (value unitv)
+{
+ CAMLparam1 (unitv);
+
+ /* arg is of type unit = void */
+ int r;
+
+ NONBLOCKING (r = virEventRegisterDefaultImpl ());
+ /* must be called before connection, therefore we can't use CHECK_ERROR
*/
+ if (r == -1) caml_failwith("virEventRegisterDefaultImpl");
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_event_run_default_impl (value unitv)
+{
+ CAMLparam1 (unitv);
+
+ /* arg is of type unit = void */
+ int r;
+
+ NONBLOCKING (r = virEventRunDefaultImpl ());
+ if (r == -1) caml_failwith("virEventRunDefaultImpl");
+
+ CAMLreturn (Val_unit);
+}
+
+/* We register a single C callback function for every distinct
+ callback signature. We encode the signature itself in the function
+ name and also in the name of the assocated OCaml callback
+ e.g.:
+ a C function called
+ i_i64_s_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ int x,
+ long y,
+ char *z,
+ void *opaque)
+ would correspond to an OCaml callback
+ Libvirt.i_i64_s_callback :
+ int64 -> [`R] Domain.t -> int -> int64 -> string option ->
unit
+ where the initial int64 is a unique ID used by the OCaml to
+ dispatch to the specific OCaml closure and stored by libvirt
+ as the "opaque" data. */
+
+/* Every one of the callbacks starts with a DOMAIN_CALLBACK_BEGIN(NAME)
+ where NAME is the string name of the OCaml callback registered
+ in libvirt.ml. */
+#define DOMAIN_CALLBACK_BEGIN(NAME) \
+ value connv, domv, callback_id, result; \
+ connv = domv = callback_id = result = Val_int(0); \
+ static value *callback = NULL; \
+ caml_leave_blocking_section(); \
+ if (callback == NULL) \
+ callback = caml_named_value(NAME); \
+ if (callback == NULL) \
+ abort(); /* C code out of sync with OCaml code */ \
+ if ((virDomainRef(dom) == -1) || (virConnectRef(conn) == -1)) \
+ abort(); /* should never happen in practice? */ \
+ \
+ Begin_roots4(connv, domv, callback_id, result); \
+ connv = Val_connect(conn); \
+ domv = Val_domain(dom, connv); \
+ callback_id = caml_copy_int64(*(long *)opaque);
+
+/* Every one of the callbacks ends with a CALLBACK_END */
+#define DOMAIN_CALLBACK_END \
+ (void) caml_callback3(*callback, callback_id, domv, result); \
+ End_roots(); \
+ caml_enter_blocking_section();
+
+
+static void
+i_i_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ int x,
+ int y,
+ void * opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.i_i_callback")
+ result = caml_alloc_tuple(2);
+ Store_field(result, 0, Val_int(x));
+ Store_field(result, 1, Val_int(y));
+ DOMAIN_CALLBACK_END
+}
+
+static void
+u_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ void *opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.u_callback")
+ result = Val_int(0); /* () */
+ DOMAIN_CALLBACK_END
+}
+
+static void
+i64_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ long long int64,
+ void *opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.i64_callback")
+ result = caml_copy_int64(int64);
+ DOMAIN_CALLBACK_END
+}
+
+static void
+i_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ int x,
+ void *opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.i_callback")
+ result = Val_int(x);
+ DOMAIN_CALLBACK_END
+}
+
+static void
+s_i_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ char *x,
+ int y,
+ void * opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.s_i_callback")
+ result = caml_alloc_tuple(2);
+ Store_field(result, 0,
+ Val_opt(x, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 1, Val_int(y));
+ DOMAIN_CALLBACK_END
+}
+
+static void
+s_i_i_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ char *x,
+ int y,
+ int z,
+ void * opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.s_i_i_callback")
+ result = caml_alloc_tuple(3);
+ Store_field(result, 0,
+ Val_opt(x, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 1, Val_int(y));
+ Store_field(result, 2, Val_int(z));
+ DOMAIN_CALLBACK_END
+}
+
+static void
+s_s_i_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ char *x,
+ char *y,
+ int z,
+ void *opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_i_callback")
+ result = caml_alloc_tuple(3);
+ Store_field(result, 0,
+ Val_opt(x, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 1,
+ Val_opt(y, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 2, Val_int(z));
+ DOMAIN_CALLBACK_END
+}
+
+static void
+s_s_i_s_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ char *x,
+ char *y,
+ int z,
+ char *a,
+ void *opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_i_s_callback")
+ result = caml_alloc_tuple(4);
+ Store_field(result, 0,
+ Val_opt(x, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 1,
+ Val_opt(y, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 2, Val_int(z));
+ Store_field(result, 3,
+ Val_opt(a, (Val_ptr_t) caml_copy_string));
+ DOMAIN_CALLBACK_END
+}
+
+static void
+s_s_s_i_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ char * x,
+ char * y,
+ char * z,
+ int a,
+ void * opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_s_i_callback")
+ result = caml_alloc_tuple(4);
+ Store_field(result, 0,
+ Val_opt(x, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 1,
+ Val_opt(y, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 2,
+ Val_opt(z, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 3, Val_int(a));
+ DOMAIN_CALLBACK_END
+}
+
+static value
+Val_event_graphics_address(virDomainEventGraphicsAddressPtr x)
+{
+ CAMLparam0 ();
+ CAMLlocal1(result);
+ result = caml_alloc_tuple(3);
+ Store_field(result, 0, Val_int(x->family));
+ Store_field(result, 1,
+ Val_opt((void *) x->node, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 2,
+ Val_opt((void *) x->service, (Val_ptr_t) caml_copy_string));
+ CAMLreturn(result);
+}
+
+static value
+Val_event_graphics_subject_identity(virDomainEventGraphicsSubjectIdentityPtr x)
+{
+ CAMLparam0 ();
+ CAMLlocal1(result);
+ result = caml_alloc_tuple(2);
+ Store_field(result, 0,
+ Val_opt((void *) x->type, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 1,
+ Val_opt((void *) x->name, (Val_ptr_t) caml_copy_string));
+ CAMLreturn(result);
+
+}
+
+static value
+Val_event_graphics_subject(virDomainEventGraphicsSubjectPtr x)
+{
+ CAMLparam0 ();
+ CAMLlocal1(result);
+ int i;
+ result = caml_alloc_tuple(x->nidentity);
+ for (i = 0; i < x->nidentity; i++ )
+ Store_field(result, i,
+ Val_event_graphics_subject_identity(x->identities + i));
+ CAMLreturn(result);
+}
+
+static void
+i_ga_ga_s_gs_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ int i1,
+ virDomainEventGraphicsAddressPtr ga1,
+ virDomainEventGraphicsAddressPtr ga2,
+ char *s1,
+ virDomainEventGraphicsSubjectPtr gs1,
+ void * opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.i_ga_ga_s_gs_callback")
+ result = caml_alloc_tuple(5);
+ Store_field(result, 0, Val_int(i1));
+ Store_field(result, 1, Val_event_graphics_address(ga1));
+ Store_field(result, 2, Val_event_graphics_address(ga2));
+ Store_field(result, 3,
+ Val_opt(s1, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 4, Val_event_graphics_subject(gs1));
+ DOMAIN_CALLBACK_END
+}
+
+static void
+timeout_callback(int timer, void *opaque)
+{
+ value callback_id, result;
+ callback_id = result = Val_int(0);
+ static value *callback = NULL;
+ caml_leave_blocking_section();
+ if (callback == NULL)
+ callback = caml_named_value("Libvirt.timeout_callback");
+ if (callback == NULL)
+ abort(); /* C code out of sync with OCaml code */
+
+ Begin_roots2(callback_id, result);
+ callback_id = caml_copy_int64(*(long *)opaque);
+
+ (void)caml_callback_exn(*callback, callback_id);
+ End_roots();
+ caml_enter_blocking_section();
+}
+
+CAMLprim value
+ocaml_libvirt_event_add_timeout (value connv, value ms, value callback_id)
+{
+ CAMLparam3 (connv, ms, callback_id);
+ void *opaque;
+ virFreeCallback freecb = free;
+ virEventTimeoutCallback cb = timeout_callback;
+
+ int r;
+
+ /* Store the int64 callback_id as the opaque data so the OCaml
+ callback can demultiplex to the correct OCaml handler. */
+ if ((opaque = malloc(sizeof(long))) == NULL)
+ caml_failwith ("virEventAddTimeout: malloc");
+ *((long*)opaque) = Int64_val(callback_id);
+ NONBLOCKING(r = virEventAddTimeout(Int_val(ms), cb, opaque, freecb));
+ CHECK_ERROR(r == -1, "virEventAddTimeout");
+
+ CAMLreturn(Val_int(r));
+}
+
+CAMLprim value
+ocaml_libvirt_event_remove_timeout (value connv, value timer_id)
+{
+ CAMLparam2 (connv, timer_id);
+ int r;
+
+ NONBLOCKING(r = virEventRemoveTimeout(Int_val(timer_id)));
+ CHECK_ERROR(r == -1, "virEventRemoveTimeout");
+
+ CAMLreturn(Val_int(r));
+}
+
+CAMLprim value
+ocaml_libvirt_connect_domain_event_register_any(value connv, value domv, value
callback, value callback_id)
+{
+ CAMLparam4(connv, domv, callback, callback_id);
+
+ virConnectPtr conn = Connect_val (connv);
+ virDomainPtr dom = NULL;
+ int eventID = Tag_val(callback);
+
+ virConnectDomainEventGenericCallback cb;
+ void *opaque;
+ virFreeCallback freecb = free;
+ int r;
+
+ if (domv != Val_int(0))
+ dom = Domain_val (Field(domv, 0));
+
+ switch (eventID){
+ case VIR_DOMAIN_EVENT_ID_LIFECYCLE:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i_i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_REBOOT:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(u_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_RTC_CHANGE:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i64_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_WATCHDOG:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_IO_ERROR:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_GRAPHICS:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i_ga_ga_s_gs_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_IO_ERROR_REASON:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_i_s_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_CONTROL_ERROR:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(u_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_BLOCK_JOB:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(s_i_i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_DISK_CHANGE:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_s_i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_TRAY_CHANGE:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(s_i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_PMWAKEUP:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_PMSUSPEND:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_BALLOON_CHANGE:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i64_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_PMSUSPEND_DISK:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
+ break;
+ default:
+ caml_failwith("vifConnectDomainEventRegisterAny: unimplemented
eventID");
+ }
+
+ /* Store the int64 callback_id as the opaque data so the OCaml
+ callback can demultiplex to the correct OCaml handler. */
+ if ((opaque = malloc(sizeof(long))) == NULL)
+ caml_failwith ("virConnectDomainEventRegisterAny: malloc");
+ *((long*)opaque) = Int64_val(callback_id);
+ NONBLOCKING(r = virConnectDomainEventRegisterAny(conn, dom, eventID, cb,
opaque, freecb));
+ CHECK_ERROR(r == -1, "virConnectDomainEventRegisterAny");
+
+ CAMLreturn(Val_int(r));
+}
+
+CAMLprim value
+ocaml_libvirt_storage_pool_get_info (value poolv)
+{
+ CAMLparam1 (poolv);
+ CAMLlocal2 (rv, v);
+ virStoragePoolPtr pool = Pool_val (poolv);
+ virStoragePoolInfo info;
+ int r;
+
+ NONBLOCKING (r = virStoragePoolGetInfo (pool, &info));
+ CHECK_ERROR (r == -1, "virStoragePoolGetInfo");
+
+ rv = caml_alloc (4, 0);
+ Store_field (rv, 0, Val_int (info.state));
+ v = caml_copy_int64 (info.capacity); Store_field (rv, 1, v);
+ v = caml_copy_int64 (info.allocation); Store_field (rv, 2, v);
+ v = caml_copy_int64 (info.available); Store_field (rv, 3, v);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_storage_vol_get_info (value volv)
+{
+ CAMLparam1 (volv);
+ CAMLlocal2 (rv, v);
+ virStorageVolPtr vol = Volume_val (volv);
+ virStorageVolInfo info;
+ int r;
+
+ NONBLOCKING (r = virStorageVolGetInfo (vol, &info));
+ CHECK_ERROR (r == -1, "virStorageVolGetInfo");
+
+ rv = caml_alloc (3, 0);
+ Store_field (rv, 0, Val_int (info.type));
+ v = caml_copy_int64 (info.capacity); Store_field (rv, 1, v);
+ v = caml_copy_int64 (info.allocation); Store_field (rv, 2, v);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_secret_lookup_by_usage (value connv, value usagetypev, value
usageidv)
+{
+ CAMLparam3 (connv, usagetypev, usageidv);
+ CAMLlocal1 (rv);
+ virConnectPtr conn = Connect_val (connv);
+ int usageType = Int_val (usagetypev);
+ const char *usageID = String_val (usageidv);
+ virSecretPtr r;
+
+ NONBLOCKING (r = virSecretLookupByUsage (conn, usageType, usageID));
+ CHECK_ERROR (!r, "virSecretLookupByUsage");
+
+ rv = Val_secret (r, connv);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_secret_set_value (value secv, value vv)
+{
+ CAMLparam2 (secv, vv);
+ virSecretPtr sec = Secret_val (secv);
+ const unsigned char *secval = (unsigned char *) String_val (vv);
+ const size_t size = caml_string_length (vv);
+ int r;
+
+ NONBLOCKING (r = virSecretSetValue (sec, secval, size, 0));
+ CHECK_ERROR (r == -1, "virSecretSetValue");
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_secret_get_value (value secv)
+{
+ CAMLparam1 (secv);
+ CAMLlocal1 (rv);
+ virSecretPtr sec = Secret_val (secv);
+ unsigned char *secval;
+ size_t size = 0;
+
+ NONBLOCKING (secval = virSecretGetValue (sec, &size, 0));
+ CHECK_ERROR (secval == NULL, "virSecretGetValue");
+
+ rv = caml_alloc_string (size);
+ memcpy (String_val (rv), secval, size);
+ free (secval);
+
+ CAMLreturn (rv);
+}
+
+/*----------------------------------------------------------------------*/
+
+CAMLprim value
+ocaml_libvirt_virterror_get_last_error (value unitv)
+{
+ CAMLparam1 (unitv);
+ CAMLlocal1 (rv);
+ virErrorPtr err = virGetLastError ();
+
+ rv = Val_opt (err, (Val_ptr_t) Val_virterror);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_virterror_get_last_conn_error (value connv)
+{
+ CAMLparam1 (connv);
+ CAMLlocal1 (rv);
+ virConnectPtr conn = Connect_val (connv);
+
+ rv = Val_opt (conn, (Val_ptr_t) Val_connect);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_virterror_reset_last_error (value unitv)
+{
+ CAMLparam1 (unitv);
+ virResetLastError ();
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_virterror_reset_last_conn_error (value connv)
+{
+ CAMLparam1 (connv);
+ virConnectPtr conn = Connect_val (connv);
+ virConnResetLastError (conn);
+ CAMLreturn (Val_unit);
+}
+
+/*----------------------------------------------------------------------*/
+
+static void
+ignore_errors (void *user_data, virErrorPtr error)
+{
+ /* do nothing */
+}
+
+/* Initialise the library. */
+CAMLprim value
+ocaml_libvirt_init (value unit)
+{
+ CAMLparam1 (unit);
+
+ virSetErrorFunc (NULL, ignore_errors);
+ virInitialize ();
+
+ CAMLreturn (Val_unit);
+}
diff --git a/common/mllibvirt/libvirt_c_prologue.c
b/common/mllibvirt/libvirt_c_prologue.c
new file mode 100644
index 000000000..8533618c6
--- /dev/null
+++ b/common/mllibvirt/libvirt_c_prologue.c
@@ -0,0 +1,134 @@
+/* OCaml bindings for libvirt.
+ * (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+ * https://libvirt.org/
+ *
+ * This library 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; either
+ * version 2 of the License, or (at your option) any later version,
+ * with the OCaml linking exception described in ../COPYING.LIB.
+ *
+ * This library 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.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+ */
+
+/* Please read libvirt/README file. */
+
+static const char *Optstring_val (value strv);
+typedef value (*Val_ptr_t) (void *);
+static value Val_opt (void *ptr, Val_ptr_t Val_ptr);
+typedef value (*Val_const_ptr_t) (const void *);
+static value Val_opt_const (const void *ptr, Val_const_ptr_t Val_ptr);
+/*static value option_default (value option, value deflt);*/
+static void _raise_virterror (const char *fn) Noreturn;
+static value Val_virterror (virErrorPtr err);
+static int _list_length (value listv);
+static value Val_virconnectcredential (const virConnectCredentialPtr cred);
+
+/* Use this around synchronous libvirt API calls to release the OCaml
+ * lock, allowing other threads to run simultaneously. 'code' must not
+ * perform any caml_* calls, run any OCaml code, or raise any exception.
+ *
https://web.archive.org/web/20030521020915/http://caml.inria.fr/archives/200106/msg00199.html
+ */
+#define NONBLOCKING(code) \
+ do { \
+ caml_enter_blocking_section (); \
+ code; \
+ caml_leave_blocking_section (); \
+ } while (0)
+
+/* Empty macro to use as empty parameter for other macros, since
+ * a null token as parameter when calling a macro is not allowed
+ * before C99.
+ */
+#define EMPTY
+/* Check error condition from a libvirt function, and automatically raise
+ * an exception if one is found.
+ */
+#define CHECK_ERROR_CLEANUP(cond, cleanup, fn) \
+ do { if (cond) { cleanup; _raise_virterror (fn); } } while (0)
+#define CHECK_ERROR(cond, fn) \
+ CHECK_ERROR_CLEANUP(cond, EMPTY, fn)
+
+/*----------------------------------------------------------------------*/
+
+/* Some notes about the use of custom blocks to store virConnectPtr,
+ * virDomainPtr and virNetworkPtr.
+ *------------------------------------------------------------------
+ *
+ * Libvirt does some tricky reference counting to keep track of
+ * virConnectPtr's, virDomainPtr's and virNetworkPtr's.
+ *
+ * There is only one function which can return a virConnectPtr
+ * (virConnectOpen*) and that allocates a new one each time.
+ *
+ * virDomainPtr/virNetworkPtr's on the other hand can be returned
+ * repeatedly (for the same underlying domain/network), and we must
+ * keep track of each one and explicitly free it with virDomainFree
+ * or virNetworkFree. If we lose track of one then the reference
+ * counting in libvirt will keep it open. We therefore wrap these
+ * in a custom block with a finalizer function.
+ *
+ * We also have to allow the user to explicitly free them, in
+ * which case we set the pointer inside the custom block to NULL.
+ * The finalizer notices this and doesn't free the object.
+ *
+ * Domains and networks "belong to" a connection. We have to avoid
+ * the situation like this:
+ *
+ * let conn = Connect.open ... in
+ * let dom = Domain.lookup_by_id conn 0 in
+ * (* conn goes out of scope and is garbage collected *)
+ * printf "dom name = %s\n" (Domain.get_name dom)
+ *
+ * The reason is that when conn is garbage collected, virConnectClose
+ * is called and any subsequent operations on dom will fail (in fact
+ * will probably segfault). To stop this from happening, the OCaml
+ * wrappers store domains (and networks) as explicit (dom, conn)
+ * pairs.
+ *
+ * Update 2008/01: Storage pools and volumes work the same way as
+ * domains and networks.
+ */
+
+/* Unwrap a custom block. */
+#define Connect_val(rv) (*((virConnectPtr *)Data_custom_val(rv)))
+#define Dom_val(rv) (*((virDomainPtr *)Data_custom_val(rv)))
+#define Net_val(rv) (*((virNetworkPtr *)Data_custom_val(rv)))
+#define Pol_val(rv) (*((virStoragePoolPtr *)Data_custom_val(rv)))
+#define Vol_val(rv) (*((virStorageVolPtr *)Data_custom_val(rv)))
+#define Sec_val(rv) (*((virSecretPtr *)Data_custom_val(rv)))
+
+/* Wrap up a pointer to something in a custom block. */
+static value Val_connect (virConnectPtr conn);
+static value Val_dom (virDomainPtr dom);
+static value Val_net (virNetworkPtr net);
+static value Val_pol (virStoragePoolPtr pool);
+static value Val_vol (virStorageVolPtr vol);
+static value Val_sec (virSecretPtr sec);
+
+/* Domains and networks are stored as pairs (dom/net, conn), so have
+ * some convenience functions for unwrapping and wrapping them.
+ */
+#define Domain_val(rv) (Dom_val(Field((rv),0)))
+#define Network_val(rv) (Net_val(Field((rv),0)))
+#define Pool_val(rv) (Pol_val(Field((rv),0)))
+#define Volume_val(rv) (Vol_val(Field((rv),0)))
+#define Secret_val(rv) (Sec_val(Field((rv),0)))
+#define Connect_domv(rv) (Connect_val(Field((rv),1)))
+#define Connect_netv(rv) (Connect_val(Field((rv),1)))
+#define Connect_polv(rv) (Connect_val(Field((rv),1)))
+#define Connect_volv(rv) (Connect_val(Field((rv),1)))
+#define Connect_secv(rv) (Connect_val(Field((rv),1)))
+
+static value Val_domain (virDomainPtr dom, value connv);
+static value Val_network (virNetworkPtr net, value connv);
+static value Val_pool (virStoragePoolPtr pol, value connv);
+static value Val_volume (virStorageVolPtr vol, value connv);
+static value Val_secret (virSecretPtr sec, value connv);
diff --git a/configure.ac b/configure.ac
index b48dfefb9..c3d7ba0d1 100644
--- a/configure.ac
+++ b/configure.ac
@@ -237,6 +237,7 @@ AC_CONFIG_FILES([Makefile
common/miniexpect/Makefile
common/mlaugeas/Makefile
common/mlgettext/Makefile
+ common/mllibvirt/Makefile
common/mlpcre/Makefile
common/mlprogress/Makefile
common/mlstdutils/Makefile
--
2.17.2
Pino Toscano
2018-Nov-27 10:59 UTC
[Libguestfs] [PATCH v2 3/7] v2v: switch to ocaml-libvirt
Currently virt-v2v has few custom C-based functions for libvirt
operations, which are limited in what they do, and there is a lot of
duplicated code.
Instead, switch to ocaml-libvirt for all the libvirt interaction
currently done by the Libvirt_utils module. This has few advantages:
- each input & output module now opens a libvirt connection only once,
only when needed
- no need to pass URIs and passwords around, if not needed
- a wider range of libvirt APIs can now be used, with no need to create
bindings manually
The hierarchy of input_libvirt* classes is changed to take a Lazy object
with the libvirt connection, accessing it through a "proctected"
method:
this way, the connection is opened only at the first access.
Also, the Libvirt_utils module now is just helpers around the Libvirt
module, to centralize error handling, and few common operations.
---
docs/C_SOURCE_FILES | 1 -
po/POTFILES | 1 -
v2v/Makefile.am | 6 +-
v2v/copy_to_local.ml | 7 +-
v2v/dummy.c | 2 +
v2v/input_libvirt.ml | 20 +-
v2v/input_libvirt_other.ml | 27 +-
v2v/input_libvirt_other.mli | 5 +-
v2v/input_libvirt_vcenter_https.ml | 13 +-
v2v/input_libvirt_vcenter_https.mli | 2 +-
v2v/input_libvirt_vddk.ml | 15 +-
v2v/input_libvirt_vddk.mli | 4 +-
v2v/input_libvirt_xen_ssh.ml | 13 +-
v2v/input_libvirt_xen_ssh.mli | 2 +-
v2v/input_libvirtxml.ml | 3 +-
v2v/libvirt_utils-c.c | 517 ----------------------------
v2v/libvirt_utils.ml | 95 ++++-
v2v/libvirt_utils.mli | 51 ++-
v2v/output_libvirt.ml | 17 +-
v2v/parse_libvirt_xml.ml | 14 +-
v2v/parse_libvirt_xml.mli | 11 +-
21 files changed, 201 insertions(+), 625 deletions(-)
create mode 100644 v2v/dummy.c
delete mode 100644 v2v/libvirt_utils-c.c
diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES
index 7f1c60b30..519acedd5 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -414,6 +414,5 @@ utils/boot-analysis/boot-analysis.h
utils/boot-benchmark/boot-benchmark.c
utils/qemu-boot/qemu-boot.c
utils/qemu-speed-test/qemu-speed-test.c
-v2v/libvirt_utils-c.c
v2v/qemuopts-c.c
v2v/test-harness/dummy.c
diff --git a/po/POTFILES b/po/POTFILES
index 79f4b8c56..8d603162f 100644
--- a/po/POTFILES
+++ b/po/POTFILES
@@ -471,6 +471,5 @@ utils/boot-benchmark/boot-benchmark.c
utils/max-disks/max-disks.pl
utils/qemu-boot/qemu-boot.c
utils/qemu-speed-test/qemu-speed-test.c
-v2v/libvirt_utils-c.c
v2v/qemuopts-c.c
v2v/test-harness/dummy.c
diff --git a/v2v/Makefile.am b/v2v/Makefile.am
index 97ae6d0c6..75f25b3d7 100644
--- a/v2v/Makefile.am
+++ b/v2v/Makefile.am
@@ -154,7 +154,6 @@ SOURCES_ML = \
v2v.ml
SOURCES_C = \
- libvirt_utils-c.c \
qemuopts-c.c
# These files are generated and contain *.py embedded as an OCaml string.
@@ -203,6 +202,7 @@ OCAMLPACKAGES = \
-I $(top_builddir)/common/mlpcre \
-I $(top_builddir)/common/mlxml \
-I $(top_builddir)/common/mltools \
+ -I $(top_builddir)/common/mllibvirt \
-I $(top_builddir)/customize
if HAVE_OCAML_PKG_GETTEXT
OCAMLPACKAGES += -package gettext-stub
@@ -233,6 +233,7 @@ OCAMLLINKFLAGS = \
mlxml.$(MLARCHIVE) \
mlcutils.$(MLARCHIVE) \
mltools.$(MLARCHIVE) \
+ mllibvirt.$(MLARCHIVE) \
$(LINK_CUSTOM_OCAMLC_ONLY)
virt_v2v_DEPENDENCIES = $(OBJECTS) $(top_srcdir)/ocaml-link.sh
@@ -242,7 +243,7 @@ virt_v2v_LINK = \
$(OBJECTS) -o $@
virt_v2v_copy_to_local_SOURCES = \
- libvirt_utils-c.c
+ dummy.c
virt_v2v_copy_to_local_CPPFLAGS = \
-I. \
-I$(top_builddir) \
@@ -275,6 +276,7 @@ virt_v2v_copy_to_local_DEPENDENCIES = \
../common/mlpcre/mlpcre.$(MLARCHIVE) \
../common/mlutils/mlcutils.$(MLARCHIVE) \
../common/mltools/mltools.$(MLARCHIVE) \
+ ../common/mllibvirt/mllibvirt.$(MLARCHIVE) \
$(top_srcdir)/ocaml-link.sh
virt_v2v_copy_to_local_LINK = \
$(top_srcdir)/ocaml-link.sh -cclib '$(OCAMLCLIBS)' -- \
diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
index 86ff72b3a..2882fdc2f 100644
--- a/v2v/copy_to_local.ml
+++ b/v2v/copy_to_local.ml
@@ -125,7 +125,12 @@ read the man page virt-v2v-copy-to-local(1).
(* Get the remote libvirt XML. *)
message (f_"Fetching the remote libvirt XML metadata ...");
- let xml = Libvirt_utils.dumpxml ?password_file ~conn:input_conn guest_name in
+ let xml + let auth = Libvirt_utils.auth_for_password_file ?password_file
() in
+ let conn = Libvirt.Connect.connect_auth ~name:input_conn auth in
+ let dom = Libvirt_utils.get_domain conn guest_name in
+ (* Use XmlSecure to get passwords (RHBZ#1174123). *)
+ Libvirt.Domain.get_xml_desc_flags dom [Libvirt.Domain.XmlSecure] in
debug "libvirt XML from remote server:\n%s" xml;
diff --git a/v2v/dummy.c b/v2v/dummy.c
new file mode 100644
index 000000000..ebab6198c
--- /dev/null
+++ b/v2v/dummy.c
@@ -0,0 +1,2 @@
+/* Dummy source, to be used for OCaml-based tools with no C sources. */
+enum { foo = 1 };
diff --git a/v2v/input_libvirt.ml b/v2v/input_libvirt.ml
index 2803c00f9..bd2ac2475 100644
--- a/v2v/input_libvirt.ml
+++ b/v2v/input_libvirt.ml
@@ -28,9 +28,17 @@ open Utils
(* Choose the right subclass based on the URI. *)
let input_libvirt input_conn input_password input_transport guest + (* Create
a lazy object to open the connection to libvirt only when
+ * needed.
+ *)
+ let lazy_conn + lazy (
+ let auth = Libvirt_utils.auth_for_password_file
?password_file:input_password () in
+ Libvirt.Connect.connect_auth ?name:input_conn auth
+ ) in
match input_conn with
| None ->
- Input_libvirt_other.input_libvirt_other input_conn input_password guest
+ Input_libvirt_other.input_libvirt_other lazy_conn guest
| Some orig_uri ->
let { Xml.uri_server = server; uri_scheme = scheme } as parsed_uri @@
-45,22 +53,22 @@ let input_libvirt input_conn input_password input_transport
guest
| Some _, None, _ (* No scheme? *)
| Some _, Some "", _ ->
- Input_libvirt_other.input_libvirt_other input_conn input_password guest
+ Input_libvirt_other.input_libvirt_other lazy_conn guest
(* vCenter over https. *)
| Some server, Some ("esx"|"gsx"|"vpx"), None
->
Input_libvirt_vcenter_https.input_libvirt_vcenter_https
- input_conn input_password parsed_uri server guest
+ lazy_conn input_password parsed_uri server guest
(* vCenter or ESXi using nbdkit vddk plugin *)
| Some server, Some ("esx"|"gsx"|"vpx"), Some
(`VDDK vddk_options) ->
- Input_libvirt_vddk.input_libvirt_vddk input_conn input_password
+ Input_libvirt_vddk.input_libvirt_vddk lazy_conn input_conn
input_password
vddk_options parsed_uri guest
(* Xen over SSH *)
| Some server, Some "xen+ssh", _ ->
Input_libvirt_xen_ssh.input_libvirt_xen_ssh
- input_conn input_password parsed_uri server guest
+ lazy_conn parsed_uri server guest
(* Old virt-v2v also supported qemu+ssh://. However I am
* deliberately not supporting this in new virt-v2v. Don't
@@ -71,6 +79,6 @@ let input_libvirt input_conn input_password input_transport
guest | Some _, Some _, _ ->
warning (f_"no support for remote libvirt connections to '-ic
%s'. The conversion may fail when it tries to read the source disks.")
orig_uri;
- Input_libvirt_other.input_libvirt_other input_conn input_password guest
+ Input_libvirt_other.input_libvirt_other lazy_conn guest
let () = Modules_list.register_input_module "libvirt"
diff --git a/v2v/input_libvirt_other.ml b/v2v/input_libvirt_other.ml
index 1414fe4f9..3fcf67917 100644
--- a/v2v/input_libvirt_other.ml
+++ b/v2v/input_libvirt_other.ml
@@ -40,35 +40,28 @@ let error_if_libvirt_does_not_support_json_backingfile ()
error (f_"because of libvirt bug https://bugzilla.redhat.com/1134878 you
must EITHER upgrade to libvirt >= 2.1.0 OR set this environment
variable:\n\nexport LIBGUESTFS_BACKEND=direct\n\nand then rerun the virt-v2v
command.")
(* Superclass. *)
-class virtual input_libvirt input_conn (input_password : string option) guest
-object
+class virtual input_libvirt lazy_conn guest +object (self)
inherit input
method as_options - sprintf "-i libvirt%s %s"
- (match input_conn with
- | None -> ""
- | Some uri -> " -ic " ^ uri)
- guest
+ sprintf "-i libvirt -ic %s %s" (Libvirt.Connect.get_uri
self#conn) guest
+
+ method private conn : Libvirt.rw Libvirt.Connect.t + Lazy.force lazy_conn
end
(* Subclass specialized for handling anything that's *not* VMware vCenter
* or Xen.
*)
-class input_libvirt_other input_conn input_password guest -object
- inherit input_libvirt input_conn input_password guest
+class input_libvirt_other lazy_conn guest +object (self)
+ inherit input_libvirt lazy_conn guest
method source () debug "input_libvirt_other: source ()";
- (* Get the libvirt XML. This also checks (as a side-effect)
- * that the domain is not running. (RHBZ#1138586)
- *)
- let xml = Libvirt_utils.dumpxml ?password_file:input_password
- ?conn:input_conn guest in
-
- let source, disks = parse_libvirt_xml ?conn:input_conn xml in
+ let source, disks, _ = parse_libvirt_domain self#conn guest in
let disks = List.map (fun { p_source_disk = disk } -> disk) disks in
{ source with s_disks = disks }
end
diff --git a/v2v/input_libvirt_other.mli b/v2v/input_libvirt_other.mli
index 0bb162cce..eb6a171e7 100644
--- a/v2v/input_libvirt_other.mli
+++ b/v2v/input_libvirt_other.mli
@@ -20,11 +20,12 @@
val error_if_libvirt_does_not_support_json_backingfile : unit -> unit
-class virtual input_libvirt : string option -> string option -> string
-> object
+class virtual input_libvirt : Libvirt.rw Libvirt.Connect.t Lazy.t -> string
-> object
method precheck : unit -> unit
method as_options : string
method virtual source : unit -> Types.source
method adjust_overlay_parameters : Types.overlay -> unit
+ method private conn : Libvirt.rw Libvirt.Connect.t
end
-val input_libvirt_other : string option -> string option -> string ->
Types.input
+val input_libvirt_other : Libvirt.rw Libvirt.Connect.t Lazy.t -> string
-> Types.input
diff --git a/v2v/input_libvirt_vcenter_https.ml
b/v2v/input_libvirt_vcenter_https.ml
index 0f1812010..9180800c9 100644
--- a/v2v/input_libvirt_vcenter_https.ml
+++ b/v2v/input_libvirt_vcenter_https.ml
@@ -36,9 +36,9 @@ let readahead_for_copying = Some (64 * 1024 * 1024)
(* Subclass specialized for handling VMware vCenter over https. *)
class input_libvirt_vcenter_https
- input_conn input_password parsed_uri server guest -object
- inherit input_libvirt input_conn input_password guest
+ lazy_conn input_password parsed_uri server guest +object (self)
+ inherit input_libvirt lazy_conn guest
val saved_source_paths = Hashtbl.create 13
val mutable dcPath = ""
@@ -61,12 +61,7 @@ object
unsetenv "ALL_PROXY";
unsetenv "NO_PROXY";
- (* Get the libvirt XML. This also checks (as a side-effect)
- * that the domain is not running. (RHBZ#1138586)
- *)
- let xml = Libvirt_utils.dumpxml ?password_file:input_password
- ?conn:input_conn guest in
- let source, disks = parse_libvirt_xml ?conn:input_conn xml in
+ let source, disks, xml = parse_libvirt_domain self#conn guest in
(* Find the <vmware:datacenterpath> element from the XML. This
* was added in libvirt >= 1.2.20.
diff --git a/v2v/input_libvirt_vcenter_https.mli
b/v2v/input_libvirt_vcenter_https.mli
index 341caa105..74d37d829 100644
--- a/v2v/input_libvirt_vcenter_https.mli
+++ b/v2v/input_libvirt_vcenter_https.mli
@@ -18,4 +18,4 @@
(** [-i libvirt] when the source is VMware vCenter *)
-val input_libvirt_vcenter_https : string option -> string option ->
Xml.uri -> string -> string -> Types.input
+val input_libvirt_vcenter_https : Libvirt.rw Libvirt.Connect.t Lazy.t ->
string option -> Xml.uri -> string -> string -> Types.input
diff --git a/v2v/input_libvirt_vddk.ml b/v2v/input_libvirt_vddk.ml
index 9f100a3cd..f05eeb9f7 100644
--- a/v2v/input_libvirt_vddk.ml
+++ b/v2v/input_libvirt_vddk.ml
@@ -93,8 +93,8 @@ let parse_input_options options options
(* Subclass specialized for handling VMware via nbdkit vddk plugin. *)
-class input_libvirt_vddk input_conn input_password vddk_options parsed_uri
- guest +class input_libvirt_vddk lazy_conn input_conn
input_password vddk_options
+ parsed_uri guest (* The VDDK path. *)
let libdir try Some (List.assoc "libdir" vddk_options)
@@ -198,8 +198,8 @@ See also the virt-v2v-input-vmware(1) manual.") libNN
error (f_"nbdkit was compiled without SELinux support. You will
have to recompile nbdkit with libselinux-devel installed, or else set SELinux to
Permissive mode while doing the conversion.")
in
-object
- inherit input_libvirt input_conn input_password guest as super
+object (self)
+ inherit input_libvirt lazy_conn guest as super
method precheck () error_unless_vddk_libdir ();
@@ -219,12 +219,7 @@ object
pt_options
method source () - (* Get the libvirt XML. This also checks (as a
side-effect)
- * that the domain is not running. (RHBZ#1138586)
- *)
- let xml = Libvirt_utils.dumpxml ?password_file:input_password
- ?conn:input_conn guest in
- let source, disks = parse_libvirt_xml ?conn:input_conn xml in
+ let source, disks, xml = parse_libvirt_domain self#conn guest in
(* Find the <vmware:moref> element from the XML. This was added
* in libvirt >= 3.7 and is required.
diff --git a/v2v/input_libvirt_vddk.mli b/v2v/input_libvirt_vddk.mli
index d321677d8..66d5f6f15 100644
--- a/v2v/input_libvirt_vddk.mli
+++ b/v2v/input_libvirt_vddk.mli
@@ -25,7 +25,7 @@ val print_input_options : unit -> unit
val parse_input_options : (string * string) list -> vddk_options
(** Print and parse vddk -io options. *)
-val input_libvirt_vddk : string option -> string option -> vddk_options
-> Xml.uri -> string -> Types.input
-(** [input_libvirt_vddk input_conn input_password vddk_options parsed_uri
guest]
+val input_libvirt_vddk : Libvirt.rw Libvirt.Connect.t Lazy.t -> string
option -> string option -> vddk_options -> Xml.uri -> string ->
Types.input
+(** [input_libvirt_vddk lazy_conn vddk_options parsed_uri guest]
creates and returns a {!Types.input} object specialized for reading
the guest disks using the nbdkit vddk plugin. *)
diff --git a/v2v/input_libvirt_xen_ssh.ml b/v2v/input_libvirt_xen_ssh.ml
index c4b671490..cef5723ca 100644
--- a/v2v/input_libvirt_xen_ssh.ml
+++ b/v2v/input_libvirt_xen_ssh.ml
@@ -30,9 +30,9 @@ open Input_libvirt_other
open Printf
(* Subclass specialized for handling Xen over SSH. *)
-class input_libvirt_xen_ssh input_conn input_password parsed_uri server guest
-object
- inherit input_libvirt input_conn input_password guest
+class input_libvirt_xen_ssh lazy_conn parsed_uri server guest +object (self)
+ inherit input_libvirt lazy_conn guest
method precheck () if backend_is_libvirt () then
@@ -43,12 +43,7 @@ object
method source () debug "input_libvirt_xen_ssh: source: server
%s" server;
- (* Get the libvirt XML. This also checks (as a side-effect)
- * that the domain is not running. (RHBZ#1138586)
- *)
- let xml = Libvirt_utils.dumpxml ?password_file:input_password
- ?conn:input_conn guest in
- let source, disks = parse_libvirt_xml ?conn:input_conn xml in
+ let source, disks, _ = parse_libvirt_domain self#conn guest in
(* Map the <source/> filename (which is relative to the remote
* Xen server) to an ssh URI. This is a JSON URI looking something
diff --git a/v2v/input_libvirt_xen_ssh.mli b/v2v/input_libvirt_xen_ssh.mli
index 6eddb701f..bcd54796c 100644
--- a/v2v/input_libvirt_xen_ssh.mli
+++ b/v2v/input_libvirt_xen_ssh.mli
@@ -18,4 +18,4 @@
(** [-i libvirt] when the source is Xen *)
-val input_libvirt_xen_ssh : string option -> string option -> Xml.uri
-> string -> string -> Types.input
+val input_libvirt_xen_ssh : Libvirt.rw Libvirt.Connect.t Lazy.t -> Xml.uri
-> string -> string -> Types.input
diff --git a/v2v/input_libvirtxml.ml b/v2v/input_libvirtxml.ml
index 9471ebc1c..5d5c5a4c3 100644
--- a/v2v/input_libvirtxml.ml
+++ b/v2v/input_libvirtxml.ml
@@ -34,7 +34,8 @@ object
method source () let xml = read_whole_file file in
- let source, disks = parse_libvirt_xml xml in
+ let conn = Libvirt.Connect.connect () in
+ let source, disks = parse_libvirt_xml conn xml in
(* When reading libvirt XML from a file (-i libvirtxml) we allow
* paths to disk images in the libvirt XML to be relative (to the XML
diff --git a/v2v/libvirt_utils-c.c b/v2v/libvirt_utils-c.c
deleted file mode 100644
index e966c0117..000000000
--- a/v2v/libvirt_utils-c.c
+++ /dev/null
@@ -1,517 +0,0 @@
-/* virt-v2v
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- */
-
-/**
- * This module implements various C<virsh>-like commands, but with
- * non-broken authentication handling.
- */
-
-#include <config.h>
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdarg.h>
-#include <string.h>
-#include <errno.h>
-#include <libintl.h>
-
-#include <caml/alloc.h>
-#include <caml/fail.h>
-#include <caml/memory.h>
-#include <caml/mlvalues.h>
-
-#include <libvirt/libvirt.h>
-#include <libvirt/virterror.h>
-
-#include "guestfs.h"
-#include "guestfs-utils.h"
-
-#pragma GCC diagnostic ignored "-Wmissing-prototypes"
-
-#define ERROR_MESSAGE_LEN 512
-
-static void
-ignore_errors (void *ignore, virErrorPtr ignore2)
-{
- /* empty */
-}
-
-/* Get the remote domain state (running, etc.). Use virDomainGetState
- * which is most efficient, but if it's not implemented, fall back to
- * virDomainGetInfo. See equivalent code in virsh.
- */
-static int
-get_dom_state (virDomainPtr dom)
-{
- int state, reason;
- virErrorPtr err;
- virDomainInfo info;
-
- if (virDomainGetState (dom, &state, &reason, 0) == 0)
- return state;
-
- err = virGetLastError ();
- if (!err || err->code != VIR_ERR_NO_SUPPORT)
- return -1;
-
- if (virDomainGetInfo (dom, &info) == 0)
- return info.state;
-
- return -1;
-}
-
-/* See lib/libvirt-auth.c for why we need this. */
-static int
-libvirt_auth_default_wrapper (virConnectCredentialPtr cred,
- unsigned int ncred,
- void *passwordvp)
-{
- const char *password = passwordvp;
- unsigned int i;
-
- if (password) {
- /* If --password-file was specified on the command line, and the
- * libvirt handler is asking for a password, return that.
- */
- for (i = 0; i < ncred; ++i) {
- if (cred[i].type == VIR_CRED_PASSPHRASE) {
- cred[i].result = strdup (password);
- cred[i].resultlen = strlen (password);
- }
- else {
- cred[i].result = NULL;
- cred[i].resultlen = 0;
- }
- }
- return 0;
- }
- else {
- /* No --password-file so call the default handler. */
- return virConnectAuthPtrDefault->cb (cred, ncred,
- virConnectAuthPtrDefault->cbdata);
- }
-}
-
-virStoragePoolPtr
-connect_and_load_pool (value connv, value poolnamev)
-{
- CAMLparam2 (connv, poolnamev);
- const char *conn_uri = NULL;
- const char *poolname;
- /* We have to assemble the error on the stack because a dynamic
- * string couldn't be freed.
- */
- char errmsg[ERROR_MESSAGE_LEN];
- virErrorPtr err;
- virConnectPtr conn;
- virStoragePoolPtr pool;
-
- if (connv != Val_int (0))
- conn_uri = String_val (Field (connv, 0)); /* Some conn */
-
- /* We have to call the default authentication handler, not least
- * since it handles all the PolicyKit crap. However it also makes
- * coding this simpler.
- */
- conn = virConnectOpenAuth (conn_uri, virConnectAuthPtrDefault,
- VIR_CONNECT_RO);
- if (conn == NULL) {
- if (conn_uri)
- snprintf (errmsg, sizeof errmsg,
- _("cannot open libvirt connection ‘%s’"), conn_uri);
- else
- snprintf (errmsg, sizeof errmsg, _("cannot open libvirt
connection"));
- caml_invalid_argument (errmsg);
- }
-
- /* Suppress default behaviour of printing errors to stderr. Note
- * you can't set this to NULL to ignore errors; setting it to NULL
- * restores the default error handler ...
- */
- virConnSetErrorFunc (conn, NULL, ignore_errors);
-
- /* Look up the pool. */
- poolname = String_val (poolnamev);
-
- pool = virStoragePoolLookupByUUIDString (conn, poolname);
-
- if (!pool)
- pool = virStoragePoolLookupByName (conn, poolname);
-
- if (!pool) {
- err = virGetLastError ();
- snprintf (errmsg, sizeof errmsg,
- _("cannot find libvirt pool ‘%s’: %s\n\nUse ‘virsh pool-list
--all’ to list all available pools, and ‘virsh pool-dumpxml <pool>’ to
display details about a particular pool.\n\nTo set the pool which virt-v2v uses,
add the ‘-os <pool>’ option."),
- poolname, err->message);
- virConnectClose (conn);
- caml_invalid_argument (errmsg);
- }
-
- CAMLreturnT (virStoragePoolPtr, pool);
-}
-
-value
-v2v_dumpxml (value passwordv, value connv, value domnamev)
-{
- CAMLparam3 (passwordv, connv, domnamev);
- CAMLlocal1 (retv);
- const char *password = NULL;
- const char *conn_uri = NULL;
- const char *domname;
- virConnectAuth authdata;
- /* We have to assemble the error on the stack because a dynamic
- * string couldn't be freed.
- */
- char errmsg[ERROR_MESSAGE_LEN];
- virErrorPtr err;
- virConnectPtr conn;
- virDomainPtr dom;
- int is_test_uri = 0;
- char *xml;
-
- if (passwordv != Val_int (0))
- password = String_val (Field (passwordv, 0)); /* Some password */
-
- if (connv != Val_int (0)) {
- conn_uri = String_val (Field (connv, 0)); /* Some conn */
- is_test_uri = STRPREFIX (conn_uri, "test:");
- }
-
- /* Set up authentication wrapper. */
- authdata = *virConnectAuthPtrDefault;
- authdata.cb = libvirt_auth_default_wrapper;
- authdata.cbdata = (void *) password;
-
- /* Note this cannot be a read-only connection since we need to use
- * the VIR_DOMAIN_XML_SECURE flag below.
- */
- conn = virConnectOpenAuth (conn_uri, &authdata, 0);
- if (conn == NULL) {
- if (conn_uri)
- snprintf (errmsg, sizeof errmsg,
- _("cannot open libvirt connection ‘%s’"), conn_uri);
- else
- snprintf (errmsg, sizeof errmsg, _("cannot open libvirt
connection"));
- caml_invalid_argument (errmsg);
- }
-
- /* Suppress default behaviour of printing errors to stderr. Note
- * you can't set this to NULL to ignore errors; setting it to NULL
- * restores the default error handler ...
- */
- virConnSetErrorFunc (conn, NULL, ignore_errors);
-
- /* Look up the domain. */
- domname = String_val (domnamev);
-
- dom = virDomainLookupByUUIDString (conn, domname);
-
- if (!dom)
- dom = virDomainLookupByName (conn, domname);
-
- if (!dom) {
- err = virGetLastError ();
- snprintf (errmsg, sizeof errmsg,
- _("cannot find libvirt domain ‘%s’: %s"), domname,
err->message);
- virConnectClose (conn);
- caml_invalid_argument (errmsg);
- }
-
- /* As a side-effect we check that the domain is shut down. Of course
- * this is only appropriate for virt-v2v. (RHBZ#1138586)
- */
- if (!is_test_uri) {
- const int state = get_dom_state (dom);
-
- if (state == VIR_DOMAIN_RUNNING ||
- state == VIR_DOMAIN_BLOCKED ||
- state == VIR_DOMAIN_PAUSED) {
- snprintf (errmsg, sizeof errmsg,
- _("libvirt domain ‘%s’ is running or paused. It must be
shut down in order to perform virt-v2v conversion"),
- domname);
- virDomainFree (dom);
- virConnectClose (conn);
- caml_invalid_argument (errmsg);
- }
- }
-
- /* Use VIR_DOMAIN_XML_SECURE to get passwords (RHBZ#1174123). */
- xml = virDomainGetXMLDesc (dom, VIR_DOMAIN_XML_SECURE);
- if (xml == NULL) {
- err = virGetLastError ();
- snprintf (errmsg, sizeof errmsg,
- _("cannot fetch XML description of guest ‘%s’: %s"),
- domname, err->message);
- virDomainFree (dom);
- virConnectClose (conn);
- caml_invalid_argument (errmsg);
- }
- virDomainFree (dom);
- virConnectClose (conn);
-
- retv = caml_copy_string (xml);
- free (xml);
-
- CAMLreturn (retv);
-}
-
-value
-v2v_pool_dumpxml (value connv, value poolnamev)
-{
- CAMLparam2 (connv, poolnamev);
- CAMLlocal1 (retv);
- /* We have to assemble the error on the stack because a dynamic
- * string couldn't be freed.
- */
- char errmsg[ERROR_MESSAGE_LEN];
- virErrorPtr err;
- virConnectPtr conn;
- virStoragePoolPtr pool;
- char *xml;
-
- /* Look up the pool. */
- pool = connect_and_load_pool (connv, poolnamev);
- conn = virStoragePoolGetConnect (pool);
-
- xml = virStoragePoolGetXMLDesc (pool, 0);
- if (xml == NULL) {
- err = virGetLastError ();
- snprintf (errmsg, sizeof errmsg,
- _("cannot fetch XML description of pool ‘%s’: %s"),
- String_val (poolnamev), err->message);
- virStoragePoolFree (pool);
- virConnectClose (conn);
- caml_invalid_argument (errmsg);
- }
- virStoragePoolFree (pool);
- virConnectClose (conn);
-
- retv = caml_copy_string (xml);
- free (xml);
-
- CAMLreturn (retv);
-}
-
-value
-v2v_vol_dumpxml (value connv, value poolnamev, value volnamev)
-{
- CAMLparam3 (connv, poolnamev, volnamev);
- CAMLlocal1 (retv);
- const char *volname;
- /* We have to assemble the error on the stack because a dynamic
- * string couldn't be freed.
- */
- char errmsg[ERROR_MESSAGE_LEN];
- virErrorPtr err;
- virConnectPtr conn;
- virStoragePoolPtr pool;
- virStorageVolPtr vol;
- char *xml;
-
- /* Look up the pool. */
- pool = connect_and_load_pool (connv, poolnamev);
- conn = virStoragePoolGetConnect (pool);
-
- /* Look up the volume. */
- volname = String_val (volnamev);
-
- vol = virStorageVolLookupByName (pool, volname);
-
- if (!vol) {
- err = virGetLastError ();
- snprintf (errmsg, sizeof errmsg,
- _("cannot find libvirt volume ‘%s’: %s"), volname,
err->message);
- virStoragePoolFree (pool);
- virConnectClose (conn);
- caml_invalid_argument (errmsg);
- }
-
- xml = virStorageVolGetXMLDesc (vol, 0);
- if (xml == NULL) {
- err = virGetLastError ();
- snprintf (errmsg, sizeof errmsg,
- _("cannot fetch XML description of volume ‘%s’: %s"),
- volname, err->message);
- virStorageVolFree (vol);
- virStoragePoolFree (pool);
- virConnectClose (conn);
- caml_invalid_argument (errmsg);
- }
- virStorageVolFree (vol);
- virStoragePoolFree (pool);
- virConnectClose (conn);
-
- retv = caml_copy_string (xml);
- free (xml);
-
- CAMLreturn (retv);
-}
-
-value
-v2v_capabilities (value connv, value unitv)
-{
- CAMLparam2 (connv, unitv);
- CAMLlocal1 (capabilitiesv);
- const char *conn_uri = NULL;
- char *capabilities;
- /* We have to assemble the error on the stack because a dynamic
- * string couldn't be freed.
- */
- char errmsg[ERROR_MESSAGE_LEN];
- virErrorPtr err;
- virConnectPtr conn;
-
- if (connv != Val_int (0))
- conn_uri = String_val (Field (connv, 0)); /* Some conn */
-
- /* We have to call the default authentication handler, not least
- * since it handles all the PolicyKit crap. However it also makes
- * coding this simpler.
- */
- conn = virConnectOpenAuth (conn_uri, virConnectAuthPtrDefault,
- VIR_CONNECT_RO);
- if (conn == NULL) {
- if (conn_uri)
- snprintf (errmsg, sizeof errmsg,
- _("cannot open libvirt connection ‘%s’"), conn_uri);
- else
- snprintf (errmsg, sizeof errmsg, _("cannot open libvirt
connection"));
- caml_invalid_argument (errmsg);
- }
-
- /* Suppress default behaviour of printing errors to stderr. Note
- * you can't set this to NULL to ignore errors; setting it to NULL
- * restores the default error handler ...
- */
- virConnSetErrorFunc (conn, NULL, ignore_errors);
-
- capabilities = virConnectGetCapabilities (conn);
- if (!capabilities) {
- err = virGetLastError ();
- snprintf (errmsg, sizeof errmsg,
- _("cannot get libvirt hypervisor capabilities: %s"),
- err->message);
- virConnectClose (conn);
- caml_invalid_argument (errmsg);
- }
-
- capabilitiesv = caml_copy_string (capabilities);
- free (capabilities);
-
- virConnectClose (conn);
-
- CAMLreturn (capabilitiesv);
-}
-
-value
-v2v_domain_exists (value connv, value domnamev)
-{
- CAMLparam2 (connv, domnamev);
- const char *conn_uri = NULL;
- const char *domname;
- /* We have to assemble the error on the stack because a dynamic
- * string couldn't be freed.
- */
- char errmsg[ERROR_MESSAGE_LEN];
- virErrorPtr err;
- virConnectPtr conn;
- virDomainPtr dom;
- int domain_exists;
-
- if (connv != Val_int (0))
- conn_uri = String_val (Field (connv, 0)); /* Some conn */
-
- /* We have to call the default authentication handler, not least
- * since it handles all the PolicyKit crap. However it also makes
- * coding this simpler.
- */
- conn = virConnectOpenAuth (conn_uri, virConnectAuthPtrDefault,
- VIR_CONNECT_RO);
- if (conn == NULL) {
- if (conn_uri)
- snprintf (errmsg, sizeof errmsg,
- _("cannot open libvirt connection ‘%s’"), conn_uri);
- else
- snprintf (errmsg, sizeof errmsg, _("cannot open libvirt
connection"));
- caml_invalid_argument (errmsg);
- }
-
- /* Suppress default behaviour of printing errors to stderr. Note
- * you can't set this to NULL to ignore errors; setting it to NULL
- * restores the default error handler ...
- */
- virConnSetErrorFunc (conn, NULL, ignore_errors);
-
- /* Look up the domain. */
- domname = String_val (domnamev);
- dom = virDomainLookupByName (conn, domname);
-
- if (dom) {
- domain_exists = 1;
- virDomainFree (dom);
- }
- else {
- err = virGetLastError ();
- if (err->code == VIR_ERR_NO_DOMAIN)
- domain_exists = 0;
- else {
- snprintf (errmsg, sizeof errmsg,
- _("cannot find libvirt domain ‘%s’: %s"),
- domname, err->message);
- virConnectClose (conn);
- caml_invalid_argument (errmsg);
- }
- }
-
- virConnectClose (conn);
-
- CAMLreturn (Val_bool (domain_exists));
-}
-
-value
-v2v_libvirt_get_version (value unitv)
-{
- CAMLparam1 (unitv);
- CAMLlocal1 (rv);
- int major, minor, release;
- /* We have to assemble the error on the stack because a dynamic
- * string couldn't be freed.
- */
- char errmsg[ERROR_MESSAGE_LEN];
- unsigned long ver;
- virErrorPtr err;
-
- if (virGetVersion (&ver, NULL, NULL) == -1) {
- err = virGetLastError ();
- snprintf (errmsg, sizeof errmsg,
- _("cannot get libvirt library version: %s"),
- err->message);
- caml_invalid_argument (errmsg);
- }
-
- major = ver / 1000000UL;
- minor = ver / 1000UL % 1000UL;
- release = ver % 1000UL;
-
- rv = caml_alloc (3, 0);
- Store_field (rv, 0, Val_int (major));
- Store_field (rv, 1, Val_int (minor));
- Store_field (rv, 2, Val_int (release));
-
- CAMLreturn (rv);
-}
diff --git a/v2v/libvirt_utils.ml b/v2v/libvirt_utils.ml
index 1f5eb712a..d5beaba9e 100644
--- a/v2v/libvirt_utils.ml
+++ b/v2v/libvirt_utils.ml
@@ -17,21 +17,92 @@
*)
open Std_utils
+open Tools_utils
+open Common_gettext.Gettext
-(* This module implements various [virsh]-like commands, but with
- non-broken authentication handling. *)
+(* This module provides helper methods on top of the Libvirt
+ module. *)
-external dumpxml : ?password:string -> ?conn:string -> string ->
string = "v2v_dumpxml"
-let dumpxml ?password_file - let password = Option.map
read_first_line_from_file password_file in
- dumpxml ?password
+let auth_for_password_file ?password_file () + let auth_fn creds + let
password = Option.map read_first_line_from_file password_file in
+ List.map (
+ function
+ | { Libvirt.Connect.typ = Libvirt.Connect.CredentialPassphrase } ->
password
+ | _ -> None
+ ) creds
+ in
-external pool_dumpxml : ?conn:string -> string -> string =
"v2v_pool_dumpxml"
-external vol_dumpxml : ?conn:string -> string -> string -> string =
"v2v_vol_dumpxml"
+ {
+ Libvirt.Connect.credtype = [ Libvirt.Connect.CredentialPassphrase ];
+ cb = auth_fn;
+ }
-external capabilities : ?conn:string -> unit -> string =
"v2v_capabilities"
+let get_domain conn name + let dom + try
+ Libvirt.Domain.lookup_by_uuid_string conn name
+ with
+ (* No such domain. *)
+ | Libvirt.Virterror { code = VIR_ERR_NO_DOMAIN }
+ (* Invalid UUID string. *)
+ | Libvirt.Virterror { code = VIR_ERR_INVALID_ARG; domain = VIR_FROM_DOMAIN
} ->
+ (try
+ Libvirt.Domain.lookup_by_name conn name
+ with
+ Libvirt.Virterror { code = VIR_ERR_NO_DOMAIN; message } ->
+ error (f_"cannot find libvirt domain ‘%s’: %s")
+ name (Option.default "" message)
+ ) in
+ let uri = Libvirt.Connect.get_uri conn in
+ (* As a side-effect we check that the domain is shut down. Of course
+ * this is only appropriate for virt-v2v. (RHBZ#1138586)
+ *)
+ if not (String.is_prefix uri "test:") then (
+ (match (Libvirt.Domain.get_info dom).Libvirt.Domain.state with
+ | InfoRunning | InfoBlocked | InfoPaused ->
+ error (f_"libvirt domain ‘%s’ is running or paused. It must be shut
down in order to perform virt-v2v conversion")
+ (Libvirt.Domain.get_name dom)
+ | InfoNoState | InfoShutdown | InfoShutoff | InfoCrashed | InfoPMSuspended
->
+ ()
+ )
+ );
+ dom
-external domain_exists : ?conn:string -> string -> bool =
"v2v_domain_exists"
+let get_pool conn name + try
+ Libvirt.Pool.lookup_by_uuid_string conn name
+ with
+ (* No such pool. *)
+ | Libvirt.Virterror { code = VIR_ERR_NO_STORAGE_POOL }
+ (* Invalid UUID string. *)
+ | Libvirt.Virterror { code = VIR_ERR_INVALID_ARG; domain = VIR_FROM_STORAGE }
->
+ (try
+ Libvirt.Pool.lookup_by_name conn name
+ with Libvirt.Virterror { code = VIR_ERR_NO_STORAGE_POOL; message } ->
+ error (f_"cannot find libvirt pool ‘%s’: %s\n\nUse ‘virsh pool-list
--all’ to list all available pools, and ‘virsh pool-dumpxml <pool>’ to
display details about a particular pool.\n\nTo set the pool which virt-v2v uses,
add the ‘-os <pool>’ option.")
+ name (Option.default "" message)
+ )
-external libvirt_get_version : unit -> int * int * int
- = "v2v_libvirt_get_version"
+let get_volume pool name + try
+ Libvirt.Volume.lookup_by_name pool name
+ with
+ (* No such volume. *)
+ | Libvirt.Virterror { code = VIR_ERR_NO_STORAGE_VOL; message } ->
+ error (f_"cannot find libvirt volume ‘%s’: %s")
+ name (Option.default "" message)
+
+let domain_exists conn dom + try
+ ignore (Libvirt.Domain.lookup_by_name conn dom);
+ true
+ with
+ Libvirt.Virterror { code = VIR_ERR_NO_DOMAIN } -> false
+
+let libvirt_get_version () + let v, _ = Libvirt.get_version () in
+ let v_major = v / 1000000 in
+ let v_minor = (v / 1000) mod 1000 in
+ let v_micro = v mod 1000 in
+ (v_major, v_minor, v_micro)
diff --git a/v2v/libvirt_utils.mli b/v2v/libvirt_utils.mli
index bb65a4283..2e3956288 100644
--- a/v2v/libvirt_utils.mli
+++ b/v2v/libvirt_utils.mli
@@ -16,38 +16,35 @@
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
-(** This module implements various [virsh]-like commands, but with
- non-broken authentication handling.
+(** This module provides helper methods on top of the [Libvirt]
+ module. *)
- If you do [virsh dumpxml foo] and if the libvirt source (eg. ESX)
- requires an interactive password, then virsh unhelpfully sends the
- password prompt to stdout, which is the same place we would be
- reading the XML from. This file works around this brokenness. *)
+val auth_for_password_file : ?password_file:string -> unit ->
Libvirt.Connect.auth
+(** [auth_for_password_file ?password_file ()] returns a
+ {!Libvirt.Connect.auth} record to use when opening a new libvirt
+ connection with {!Libvirt.Connect.connect_auth} or
+ {!Libvirt.Connect.connect_auth_readonly}. The record will
+ authenticate using the password specified in the first line of
+ [?password_file], if specified. *)
-val dumpxml : ?password_file:string -> ?conn:string -> string ->
string
-(** [dumpxml ?password_file ?conn dom] returns the libvirt XML of domain [dom].
- The optional [?conn] parameter is the libvirt connection URI.
- [dom] may be a guest name or UUID. *)
+val get_domain : Libvirt.rw Libvirt.Connect.t -> string -> Libvirt.rw
Libvirt.Domain.t
+(** [get_domain conn dom] returns the libvirt domain with the
+ specified [dom] name or UUID. [conn] is the libvirt
+ connection. *)
-val pool_dumpxml : ?conn:string -> string -> string
-(** [pool_dumpxml ?conn pool] returns the libvirt XML of pool [pool].
- The optional [?conn] parameter is the libvirt connection URI.
- [pool] may be a pool name or UUID. *)
+val get_pool : Libvirt.rw Libvirt.Connect.t -> string -> Libvirt.rw
Libvirt.Pool.t
+(** [get_pool conn pool] returns the libvirt pool with the
+ specified [pool] name or UUID. [conn] is the libvirt
+ connection. *)
-val vol_dumpxml : ?conn:string -> string -> string -> string
-(** [vol_dumpxml ?conn pool vol] returns the libvirt XML of volume [vol],
- which is part of the pool [pool].
- The optional [?conn] parameter is the libvirt connection URI.
- [pool] may be a pool name or UUID. *)
+val get_volume : Libvirt.rw Libvirt.Pool.t -> string -> Libvirt.rw
Libvirt.Volume.t
+(** [get_volume pool vol] returns the libvirt volume with the
+ specified [vol] name or UUID, as part of the pool [pool]. *)
-val capabilities : ?conn:string -> unit -> string
-(** [capabilities ?conn ()] returns the libvirt capabilities XML.
- The optional [?conn] parameter is the libvirt connection URI. *)
-
-val domain_exists : ?conn:string -> string -> bool
-(** [domain_exists ?conn dom] returns a boolean indicating if the
- the libvirt XML domain [dom] exists.
- The optional [?conn] parameter is the libvirt connection URI.
+val domain_exists : Libvirt.rw Libvirt.Connect.t -> string -> bool
+(** [domain_exists conn dom] returns a boolean indicating if the
+ the libvirt XML domain [dom] exists. [conn] is the libvirt
+ connection.
[dom] may be a guest name, but not a UUID. *)
val libvirt_get_version : unit -> int * int * int
diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml
index 9008b0507..6bad91778 100644
--- a/v2v/output_libvirt.ml
+++ b/v2v/output_libvirt.ml
@@ -71,8 +71,17 @@ class output_libvirt oc output_pool = object
| Some uri -> sprintf "-o libvirt -oc %s -os %s" uri
output_pool
method prepare_targets source overlays _ _ _ _ + (* Open the connection to
libvirt. *)
+ let conn = Libvirt.Connect.connect ?name:oc () in
+
(* Get the capabilities from libvirt. *)
- let xml = Libvirt_utils.capabilities ?conn:oc () in
+ let xml + try
+ Libvirt.Connect.get_capabilities conn
+ with
+ Libvirt.Virterror { message } ->
+ error (f_"cannot get libvirt hypervisor capabilities: %s")
+ (Option.default "" message) in
debug "libvirt capabilities XML:\n%s" xml;
(* This just checks that the capabilities XML is well-formed,
@@ -87,7 +96,7 @@ class output_libvirt oc output_pool = object
capabilities_doc <- Some doc;
(* Does the domain already exist on the target? (RHBZ#889082) *)
- if Libvirt_utils.domain_exists ?conn:oc source.s_name then (
+ if Libvirt_utils.domain_exists conn source.s_name then (
if source.s_hypervisor = Physical then (* virt-p2v user *)
error (f_"a libvirt domain called ‘%s’ already exists on the
target.\n\nIf using virt-p2v, select a different ‘Name’ in the ‘Target
properties’. Or delete the existing domain on the target using the ‘virsh
undefine’ command.")
source.s_name
@@ -99,7 +108,9 @@ class output_libvirt oc output_pool = object
(* Connect to output libvirt instance and check that the pool exists
* and dump out its XML.
*)
- let xml = Libvirt_utils.pool_dumpxml ?conn:oc output_pool in
+ let xml + let pool = Libvirt_utils.get_pool conn output_pool in
+ Libvirt.Pool.get_xml_desc (Libvirt.Pool.const pool) in
let doc = Xml.parse_memory xml in
let xpathctx = Xml.xpath_new_context doc in
let xpath_string = xpath_string xpathctx in
diff --git a/v2v/parse_libvirt_xml.ml b/v2v/parse_libvirt_xml.ml
index 255c935a6..e36b772d3 100644
--- a/v2v/parse_libvirt_xml.ml
+++ b/v2v/parse_libvirt_xml.ml
@@ -71,7 +71,7 @@ let create_curl_qemu_uri driver host port path (* Turn the
JSON parameters into a 'json:' protocol string. *)
"json: " ^ JSON.string_of_doc json_params
-let parse_libvirt_xml ?conn xml +let parse_libvirt_xml conn xml debug
"libvirt xml is:\n%s" xml;
let doc = Xml.parse_memory xml in
@@ -333,7 +333,10 @@ let parse_libvirt_xml ?conn xml (match
xpath_string "source/@pool", xpath_string "source/@volume"
with
| None, None | Some _, None | None, Some _ -> ()
| Some pool, Some vol ->
- let xml = Libvirt_utils.vol_dumpxml ?conn pool vol in
+ let xml + let pool = Libvirt_utils.get_pool conn pool in
+ let vol = Libvirt_utils.get_volume pool vol in
+ Libvirt.Volume.get_xml_desc (Libvirt.Volume.const vol) in
let doc = Xml.parse_memory xml in
let xpathctx = Xml.xpath_new_context doc in
let xpath_string = Xpath_helpers.xpath_string xpathctx in
@@ -511,3 +514,10 @@ let parse_libvirt_xml ?conn xml s_nics = nics;
},
disks)
+
+let parse_libvirt_domain conn guest + let dom = Libvirt_utils.get_domain conn
guest in
+ (* Use XmlSecure to get passwords (RHBZ#1174123). *)
+ let xml = Libvirt.Domain.get_xml_desc_flags dom [Libvirt.Domain.XmlSecure] in
+ let source, disks = parse_libvirt_xml conn xml in
+ source, disks, xml
diff --git a/v2v/parse_libvirt_xml.mli b/v2v/parse_libvirt_xml.mli
index 94d5523ce..1deaf1835 100644
--- a/v2v/parse_libvirt_xml.mli
+++ b/v2v/parse_libvirt_xml.mli
@@ -27,7 +27,16 @@ and parsed_source | P_source_file of string (**
<source file> *)
| P_dont_rewrite (** s_qemu_uri is already set. *)
-val parse_libvirt_xml : ?conn:string -> string -> Types.source *
parsed_disk list
+val parse_libvirt_domain : Libvirt.rw Libvirt.Connect.t -> string ->
Types.source * parsed_disk list * string
+(** [parse_libvirt_domain conn dom] loads the XML of the domain [dom]
+ from the libvirt connection [conn].
+ The result is a tuple with a {!Types.source} structure, a list of
+ source disks, and the XML of the guest.
+
+ {b Note} the [source.s_disks] field is an empty list. The caller
+ must map over the parsed disks and update the [source.s_disks] field. *)
+
+val parse_libvirt_xml : Libvirt.rw Libvirt.Connect.t -> string ->
Types.source * parsed_disk list
(** Take libvirt XML and parse it into a {!Types.source} structure and a
list of source disks.
--
2.17.2
Pino Toscano
2018-Nov-27 10:59 UTC
[Libguestfs] [PATCH v2 4/7] v2v: -o libvirt: use a Lazy for the connection
Store the Libvirt.Connect.t object as instance variable, so it can be
used also outside of prepare_targets. Use a private method to access
it, so there is no need to directly use the Lazy object.
---
v2v/output_libvirt.ml | 16 +++++++++-------
1 file changed, 9 insertions(+), 7 deletions(-)
diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml
index 6bad91778..6971b685f 100644
--- a/v2v/output_libvirt.ml
+++ b/v2v/output_libvirt.ml
@@ -59,11 +59,16 @@ let target_features_of_capabilities_doc doc arch
List.map Xml.node_name features
)
-class output_libvirt oc output_pool = object
+class output_libvirt oc output_pool +object (self)
inherit output
val mutable capabilities_doc = None
val mutable pool_name = None
+ val lazy_conn = lazy (Libvirt.Connect.connect ?name:oc ())
+
+ method private conn : Libvirt.rw Libvirt.Connect.t + Lazy.force lazy_conn
method as_options match oc with
@@ -71,13 +76,10 @@ class output_libvirt oc output_pool = object
| Some uri -> sprintf "-o libvirt -oc %s -os %s" uri
output_pool
method prepare_targets source overlays _ _ _ _ - (* Open the connection to
libvirt. *)
- let conn = Libvirt.Connect.connect ?name:oc () in
-
(* Get the capabilities from libvirt. *)
let xml try
- Libvirt.Connect.get_capabilities conn
+ Libvirt.Connect.get_capabilities self#conn
with
Libvirt.Virterror { message } ->
error (f_"cannot get libvirt hypervisor capabilities: %s")
@@ -96,7 +98,7 @@ class output_libvirt oc output_pool = object
capabilities_doc <- Some doc;
(* Does the domain already exist on the target? (RHBZ#889082) *)
- if Libvirt_utils.domain_exists conn source.s_name then (
+ if Libvirt_utils.domain_exists self#conn source.s_name then (
if source.s_hypervisor = Physical then (* virt-p2v user *)
error (f_"a libvirt domain called ‘%s’ already exists on the
target.\n\nIf using virt-p2v, select a different ‘Name’ in the ‘Target
properties’. Or delete the existing domain on the target using the ‘virsh
undefine’ command.")
source.s_name
@@ -109,7 +111,7 @@ class output_libvirt oc output_pool = object
* and dump out its XML.
*)
let xml - let pool = Libvirt_utils.get_pool conn output_pool in
+ let pool = Libvirt_utils.get_pool self#conn output_pool in
Libvirt.Pool.get_xml_desc (Libvirt.Pool.const pool) in
let doc = Xml.parse_memory xml in
let xpathctx = Xml.xpath_new_context doc in
--
2.17.2
Pino Toscano
2018-Nov-27 10:59 UTC
[Libguestfs] [PATCH v2 5/7] v2v: -o libvirt: switch away from virsh
Now that we have a proper libvirt connection object, use it directly to
refresh the storage pool, and define the final guest. This avoids
spawning a new virsh process twice, with no possibility to even share a
possible authentication required.
---
v2v/output_libvirt.ml | 35 ++++++++++++++++-------------------
1 file changed, 16 insertions(+), 19 deletions(-)
diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml
index 6971b685f..b77c00fbe 100644
--- a/v2v/output_libvirt.ml
+++ b/v2v/output_libvirt.ml
@@ -160,14 +160,14 @@ object (self)
(* We copied directly into the final pool directory. However we
* have to tell libvirt.
*)
- let cmd = [ "virsh" ] @
- (if quiet () then [ "-q" ] else []) @
- (match oc with
- | None -> []
- | Some uri -> [ "-c"; uri; ]) @
- [ "pool-refresh"; output_pool ] in
- if run_command cmd <> 0 then
- warning (f_"could not refresh libvirt pool %s") output_pool;
+ (try
+ let pool = Libvirt_utils.get_pool self#conn output_pool in
+ Libvirt.Pool.refresh (Libvirt.Pool.const pool)
+ with
+ Libvirt.Virterror { message } ->
+ warning (f_"could not refresh libvirt pool ‘%s’: %s")
+ output_pool (Option.default "" message)
+ );
let pool_name match pool_name with
@@ -198,17 +198,14 @@ object (self)
);
(* Define the domain in libvirt. *)
- let cmd = [ "virsh" ] @
- (if quiet () then [ "-q" ] else []) @
- (match oc with
- | None -> []
- | Some uri -> [ "-c"; uri; ]) @
- [ "define"; tmpfile ] in
- if run_command cmd = 0 then (
- try Unix.unlink tmpfile with _ -> ()
- ) else (
- warning (f_"could not define libvirt domain. The libvirt XML is
still available in ‘%s’. Try running ‘virsh define %s’ yourself instead.")
- tmpfile tmpfile
+ (try
+ ignore (Libvirt.Domain.define_xml self#conn (DOM.doc_to_string doc));
+ (try Unix.unlink tmpfile with _ -> ())
+ with
+ Libvirt.Virterror { message } ->
+ warning (f_"could not define libvirt domain: %s.\nThe libvirt XML
is still available in ‘%s’. Try running ‘virsh -c %s define %s’ yourself
instead.")
+ (Option.default "" message) tmpfile
+ (Libvirt.Connect.get_uri self#conn) tmpfile
);
end
--
2.17.2
Pino Toscano
2018-Nov-27 10:59 UTC
[Libguestfs] [PATCH v2 6/7] v2v: test-harness: stop using the external ocaml-libvirt
Use the embedded copy. --- Makefile.am | 2 -- v2v/test-harness/Makefile.am | 5 ++--- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/Makefile.am b/Makefile.am index 4882894a8..4931004f7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -174,10 +174,8 @@ SUBDIRS += sparsify SUBDIRS += sysprep if HAVE_LIBVIRT SUBDIRS += v2v -if HAVE_OCAML_PKG_LIBVIRT SUBDIRS += v2v/test-harness endif -endif if HAVE_FUSE SUBDIRS += dib endif diff --git a/v2v/test-harness/Makefile.am b/v2v/test-harness/Makefile.am index 22c3b8c49..4387d29af 100644 --- a/v2v/test-harness/Makefile.am +++ b/v2v/test-harness/Makefile.am @@ -31,13 +31,12 @@ SOURCES_ML = \ v2v_test_harness.ml if HAVE_OCAML -if HAVE_OCAML_PKG_LIBVIRT # -I $(top_builddir)/lib/.libs is a hack which forces corresponding -L # option to be passed to gcc, so we don't try linking against an # installed copy of libguestfs. OCAMLPACKAGES = \ - -package str,unix,libvirt \ + -package str,unix \ -I $(top_builddir)/common/utils/.libs \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ @@ -45,6 +44,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/common/mlxml \ -I $(top_builddir)/common/mltools \ + -I $(top_builddir)/common/mllibvirt \ -I $(top_builddir)/v2v OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR) -ccopt '$(CFLAGS)' @@ -130,7 +130,6 @@ stamp-virt-v2v-test-harness.pod: virt-v2v-test-harness.pod $(top_builddir)/ocaml-dep.sh -I .. $^ -include .depend -endif endif .PHONY: docs -- 2.17.2
Pino Toscano
2018-Nov-27 10:59 UTC
[Libguestfs] [PATCH v2 7/7] build: stop looking for ocaml-libvirt
We ship our own copy of it, so we do not need the external version.
(Also, the latest upstream version of ocaml-libvirt was already not
usable to build the test harness of v2v.)
---
m4/guestfs-ocaml.m4 | 4 ----
1 file changed, 4 deletions(-)
diff --git a/m4/guestfs-ocaml.m4 b/m4/guestfs-ocaml.m4
index fea11a334..d3c4bd645 100644
--- a/m4/guestfs-ocaml.m4
+++ b/m4/guestfs-ocaml.m4
@@ -145,7 +145,6 @@ if test "x$enable_daemon" = "xyes"; then
fi
OCAML_PKG_gettext=no
-OCAML_PKG_libvirt=no
OCAML_PKG_oUnit=no
ounit_is_v2=no
have_Bytes_module=no
@@ -158,7 +157,6 @@ AS_IF([test "x$OCAMLC" != "xno"],[
GUESTFS_CREATE_COMMON_GETTEXT_ML([common/mlgettext/common_gettext.ml])
- AC_CHECK_OCAML_PKG(libvirt)
AC_CHECK_OCAML_PKG(oUnit)
# oUnit >= 2 is required, so check that it has OUnit2.
@@ -182,8 +180,6 @@ AS_IF([test "x$OCAMLC" != "xno"],[
])
AM_CONDITIONAL([HAVE_OCAML_PKG_GETTEXT],
[test "x$OCAML_PKG_gettext" != "xno"])
-AM_CONDITIONAL([HAVE_OCAML_PKG_LIBVIRT],
- [test "x$OCAML_PKG_libvirt" != "xno"])
AM_CONDITIONAL([HAVE_OCAML_PKG_OUNIT],
[test "x$OCAML_PKG_oUnit" != "xno"
&& test "x$ounit_is_v2" != "xno"])
--
2.17.2
Daniel P. Berrangé
2018-Nov-27 11:13 UTC
Re: [Libguestfs] [PATCH v2 7/7] build: stop looking for ocaml-libvirt
On Tue, Nov 27, 2018 at 11:59:08AM +0100, Pino Toscano wrote:> We ship our own copy of it, so we do not need the external version. > (Also, the latest upstream version of ocaml-libvirt was already not > usable to build the test harness of v2v.)This is a significant step backwards from a Fedora packaging POV which expects maintainers to unbundle any 3rd party deps and use the external packages instead. Why can't we just do a new release of ocaml-libvirt upstream and put that into Fedora (and other distros that care) straightaway. Regards, Daniel -- |: https://berrange.com -o- https://www.flickr.com/photos/dberrange :| |: https://libvirt.org -o- https://fstop138.berrange.com :| |: https://entangle-photo.org -o- https://www.instagram.com/dberrange :|