[Libguestfs] [PATCH v4 2/7] common: Bundle the libvirt-ocaml library for use by virt-v2v
Pino Toscano
ptoscano at redhat.com
Mon Apr 8 12:49:55 UTC 2019
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 d3ed8dcf1b0a6a8a855ceecbe0bb97f21e6665e3,
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 | 1673 ++++++++++++++++++++++++
common/mllibvirt/libvirt.mli | 1647 ++++++++++++++++++++++++
common/mllibvirt/libvirt_c_epilogue.c | 462 +++++++
common/mllibvirt/libvirt_c_oneoffs.c | 1714 +++++++++++++++++++++++++
common/mllibvirt/libvirt_c_prologue.c | 134 ++
configure.ac | 1 +
11 files changed, 6655 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 bfe44cd97..d62d5a0a0 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 cf9ca512e..259e5cd93 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..12e046c35
--- /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: $(srcdir)/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..d935bfc7c
--- /dev/null
+++ b/common/mllibvirt/libvirt.ml
@@ -0,0 +1,1673 @@
+(* 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 get_domain_capabilities : ?emulatorbin:string -> ?arch:string -> ?machine:string -> ?virttype:string -> [>`R] t -> string = "ocaml_libvirt_connect_get_domain_capabilities"
+
+ 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_INVALID_DOMAIN_CHECKPOINT
+ | VIR_ERR_NO_DOMAIN_CHECKPOINT
+ | VIR_ERR_NO_DOMAIN_BACKUP
+ | 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_INVALID_DOMAIN_CHECKPOINT -> "VIR_ERR_INVALID_DOMAIN_CHECKPOINT"
+ | VIR_ERR_NO_DOMAIN_CHECKPOINT -> "VIR_ERR_NO_DOMAIN_CHECKPOINT"
+ | VIR_ERR_NO_DOMAIN_BACKUP -> "VIR_ERR_NO_DOMAIN_BACKUP"
+ | 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_FIREWALLD
+ | VIR_FROM_DOMAIN_CHECKPOINT
+ | 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_FIREWALLD -> "VIR_FROM_FIREWALLD"
+ | VIR_FROM_DOMAIN_CHECKPOINT -> "VIR_FROM_DOMAIN_CHECKPOINT"
+ | 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..fc5a1fc1b
--- /dev/null
+++ b/common/mllibvirt/libvirt.mli
@@ -0,0 +1,1647 @@
+(** 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.2.8 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.
+ *)
+
+ val get_domain_capabilities : ?emulatorbin:string -> ?arch:string -> ?machine:string -> ?virttype:string -> [>`R] t -> string
+ (** [get_domain_capabilities ()] returns the XML with the
+ available capabilities of the emulator or libvirt for domains.
+
+ The optional flag [?emulatorbin] is used to specify a different
+ emulator.
+
+ The optional flag [?arch] is used to specify a different
+ architecture.
+
+ The optional flag [?machine] is used to specify a different
+ machine type.
+
+ The optional flag [?virttype] is used to specify a different
+ type of virtualization. *)
+
+ 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
+ | VIR_ERR_INVALID_DOMAIN_CHECKPOINT
+ | VIR_ERR_NO_DOMAIN_CHECKPOINT
+ | VIR_ERR_NO_DOMAIN_BACKUP
+ (* ^^ 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
+ | VIR_FROM_FIREWALLD
+ | VIR_FROM_DOMAIN_CHECKPOINT
+ (* ^^ 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..4d456297e
--- /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 104 /* VIR_ERR_NO_DOMAIN_BACKUP */
+#define MAX_VIR_DOMAIN 69 /* VIR_FROM_DOMAIN_CHECKPOINT */
+#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..0a9e48592
--- /dev/null
+++ b/common/mllibvirt/libvirt_c_oneoffs.c
@@ -0,0 +1,1714 @@
+/* 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_connect_get_domain_capabilities (value emulatorbinv, value archv, value machinev, value virttypev, value connv)
+{
+ CAMLparam5 (emulatorbinv, archv, machinev, virttypev, connv);
+ CAMLlocal1 (rv);
+ virConnectPtr conn = Connect_val (connv);
+ char *r;
+
+ NONBLOCKING (r = virConnectGetDomainCapabilities (conn, Optstring_val (emulatorbinv), Optstring_val (archv), Optstring_val (machinev), Optstring_val (virttypev), 0));
+ CHECK_ERROR (r == NULL, "virConnectGetDomainCapabilities");
+
+ rv = caml_copy_string (r);
+ free (r);
+ CAMLreturn (rv);
+}
+
+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 9e7df93d8..6b701bef2 100644
--- a/configure.ac
+++ b/configure.ac
@@ -243,6 +243,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.20.1
More information about the Libguestfs
mailing list