Add a copy of the libvirt-ocaml library, currently available at: https://libvirt.org/git/?p=libvirt-ocaml.git;a=summary This is a snapshot at commit 8893bf9b7dd31594943ec8a88ce63133fa7f4a72, which has all the features we need (and that builds fine). It is expected to stay synchronized with upstream, until there is a new upstream release, and it will be widespread enough. --- .gitignore | 2 + Makefile.am | 3 + common/mllibvirt/Makefile.am | 102 ++ common/mllibvirt/generator.pl | 908 +++++++++++++ common/mllibvirt/libvirt.README | 9 + common/mllibvirt/libvirt.ml | 1661 ++++++++++++++++++++++++ common/mllibvirt/libvirt.mli | 1626 +++++++++++++++++++++++ common/mllibvirt/libvirt_c_epilogue.c | 462 +++++++ common/mllibvirt/libvirt_c_oneoffs.c | 1698 +++++++++++++++++++++++++ common/mllibvirt/libvirt_c_prologue.c | 134 ++ configure.ac | 1 + 11 files changed, 6606 insertions(+) create mode 100644 common/mllibvirt/Makefile.am create mode 100755 common/mllibvirt/generator.pl create mode 100644 common/mllibvirt/libvirt.README create mode 100644 common/mllibvirt/libvirt.ml create mode 100644 common/mllibvirt/libvirt.mli create mode 100644 common/mllibvirt/libvirt_c_epilogue.c create mode 100644 common/mllibvirt/libvirt_c_oneoffs.c create mode 100644 common/mllibvirt/libvirt_c_prologue.c diff --git a/.gitignore b/.gitignore index 29d3e3aae..82c714675 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..1739303b7 --- /dev/null +++ b/common/mllibvirt/Makefile.am @@ -0,0 +1,102 @@ +# libguestfs OCaml tools common code +# Copyright (C) 2018 Red Hat Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +include $(top_srcdir)/subdir-rules.mk + +EXTRA_DIST = \ + $(SOURCES_MLI) \ + $(SOURCES_ML) \ + generator.pl \ + libvirt_c_epilogue.c \ + libvirt_c_oneoffs.c \ + libvirt_c_prologue.c \ + libvirt.README + +SOURCES_MLI = \ + libvirt.mli + +SOURCES_ML = \ + libvirt.ml + +SOURCES_C = \ + libvirt_c.c + +# Automatically generate the C code from a Perl script 'generator.pl'. +libvirt_c.c: generator.pl + $(PERL) -w $< + +CLEANFILES += \ + libvirt_c.c + +# We pretend that we're building a C library. automake handles the +# compilation of the C sources for us. At the end we take the C +# objects and OCaml objects and link them into the OCaml library. +# This C library is never used. + +noinst_LIBRARIES = libmllibvirt.a + +if !HAVE_OCAMLOPT +MLLIBVIRT_CMA = mllibvirt.cma +else +MLLIBVIRT_CMA = mllibvirt.cmxa +endif + +noinst_DATA = $(MLLIBVIRT_CMA) + +libmllibvirt_a_SOURCES = $(SOURCES_C) +libmllibvirt_a_CPPFLAGS = \ + -I. \ + -I$(top_builddir) \ + -I$(shell $(OCAMLC) -where) +libmllibvirt_a_CFLAGS = \ + $(WARN_CFLAGS) $(WERROR_CFLAGS) \ + $(LIBVIRT_CFLAGS) \ + -fPIC + +BOBJECTS = $(SOURCES_ML:.ml=.cmo) +XOBJECTS = $(BOBJECTS:.cmo=.cmx) + +OCAMLPACKAGES = +OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR) + +if !HAVE_OCAMLOPT +OBJECTS = $(BOBJECTS) +else +OBJECTS = $(XOBJECTS) +endif + +libmllibvirt_a_DEPENDENCIES = $(OBJECTS) + +$(MLLIBVIRT_CMA): $(OBJECTS) libmllibvirt.a + $(OCAMLFIND) mklib $(OCAMLPACKAGES) \ + $(OBJECTS) $(libmllibvirt_a_OBJECTS) -cclib -lvirt -o mllibvirt + +# Dependencies. +depend: .depend + +.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) + rm -f $@ $@-t + $(OCAMLFIND) ocamldep -I ../../ocaml -I $(abs_srcdir) $^ | \ + $(SED) 's/ *$$//' | \ + $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ + $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ + sort > $@-t + mv $@-t $@ + +-include .depend + +.PHONY: depend docs diff --git a/common/mllibvirt/generator.pl b/common/mllibvirt/generator.pl new file mode 100755 index 000000000..490ef9add --- /dev/null +++ b/common/mllibvirt/generator.pl @@ -0,0 +1,908 @@ +#!/usr/bin/perl -w +# +# OCaml bindings for libvirt. +# (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc. +# https://libvirt.org/ +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2 of the License, or (at your option) any later version, +# with the OCaml linking exception described in ../COPYING.LIB. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +# This generates libvirt_c.c (the core of the bindings). You don't +# need to run this program unless you are extending the bindings +# themselves (eg. because libvirt has been extended). +# +# Please read libvirt/README. + +use strict; + +#---------------------------------------------------------------------- + +# The functions in the libvirt API that we can generate. + +# The 'sig' (signature) doesn't have a meaning or any internal structure. +# It is interpreted by the generation functions below to indicate what +# "class" the function falls into, and to generate the right class of +# binding. + +my @functions = ( + { name => "virConnectClose", sig => "conn : free" }, + { name => "virConnectGetHostname", sig => "conn : string" }, + { name => "virConnectGetURI", sig => "conn : string" }, + { name => "virConnectGetType", sig => "conn : static string" }, + { name => "virConnectNumOfDomains", sig => "conn : int" }, + { name => "virConnectListDomains", sig => "conn, int : int array" }, + { name => "virConnectNumOfDefinedDomains", sig => "conn : int" }, + { name => "virConnectListDefinedDomains", + sig => "conn, int : string array" }, + { name => "virConnectNumOfNetworks", sig => "conn : int" }, + { name => "virConnectListNetworks", sig => "conn, int : string array" }, + { name => "virConnectNumOfDefinedNetworks", sig => "conn : int" }, + { name => "virConnectListDefinedNetworks", + sig => "conn, int : string array" }, + { name => "virConnectNumOfStoragePools", sig => "conn : int" }, + { name => "virConnectListStoragePools", + sig => "conn, int : string array" }, + { name => "virConnectNumOfDefinedStoragePools", + sig => "conn : int" }, + { name => "virConnectListDefinedStoragePools", + sig => "conn, int : string array" }, + { name => "virConnectNumOfSecrets", sig => "conn : int" }, + { name => "virConnectListSecrets", sig => "conn, int : string array" }, + { name => "virConnectGetCapabilities", sig => "conn : string" }, + { name => "virConnectDomainEventDeregisterAny", + sig => "conn, int : unit" }, + + { name => "virDomainCreateLinux", sig => "conn, string, 0U : dom" }, + { name => "virDomainCreateXML", sig => "conn, string, unsigned : dom" }, + { name => "virDomainFree", sig => "dom : free" }, + { name => "virDomainDestroy", sig => "dom : free" }, + { name => "virDomainLookupByName", sig => "conn, string : dom" }, + { name => "virDomainLookupByID", sig => "conn, int : dom" }, + { name => "virDomainLookupByUUID", sig => "conn, uuid : dom" }, + { name => "virDomainLookupByUUIDString", sig => "conn, string : dom" }, + { name => "virDomainGetName", sig => "dom : static string" }, + { name => "virDomainGetOSType", sig => "dom : string" }, + { name => "virDomainGetXMLDesc", sig => "dom, 0 : string" }, + { name => "virDomainGetUUID", sig => "dom : uuid" }, + { name => "virDomainGetUUIDString", sig => "dom : uuid string" }, + { name => "virDomainGetMaxVcpus", sig => "dom : int" }, + { name => "virDomainSave", sig => "dom, string : unit" }, + { name => "virDomainRestore", sig => "conn, string : unit" }, + { name => "virDomainCoreDump", sig => "dom, string, 0 : unit" }, + { name => "virDomainSuspend", sig => "dom : unit" }, + { name => "virDomainResume", sig => "dom : unit" }, + { name => "virDomainShutdown", sig => "dom : unit" }, + { name => "virDomainReboot", sig => "dom, 0 : unit" }, + { name => "virDomainDefineXML", sig => "conn, string : dom" }, + { name => "virDomainUndefine", sig => "dom : unit" }, + { name => "virDomainCreate", sig => "dom : unit" }, + { name => "virDomainAttachDevice", sig => "dom, string : unit" }, + { name => "virDomainDetachDevice", sig => "dom, string : unit" }, + { name => "virDomainGetAutostart", sig => "dom : bool" }, + { name => "virDomainSetAutostart", sig => "dom, bool : unit" }, + + { name => "virNetworkFree", sig => "net : free" }, + { name => "virNetworkDestroy", sig => "net : free" }, + { name => "virNetworkLookupByName", sig => "conn, string : net" }, + { name => "virNetworkLookupByUUID", sig => "conn, uuid : net" }, + { name => "virNetworkLookupByUUIDString", sig => "conn, string : net" }, + { name => "virNetworkGetName", sig => "net : static string" }, + { name => "virNetworkGetXMLDesc", sig => "net, 0 : string" }, + { name => "virNetworkGetBridgeName", sig => "net : string" }, + { name => "virNetworkGetUUID", sig => "net : uuid" }, + { name => "virNetworkGetUUIDString", sig => "net : uuid string" }, + { name => "virNetworkUndefine", sig => "net : unit" }, + { name => "virNetworkCreateXML", sig => "conn, string : net" }, + { name => "virNetworkDefineXML", sig => "conn, string : net" }, + { name => "virNetworkCreate", sig => "net : unit" }, + { name => "virNetworkGetAutostart", sig => "net : bool" }, + { name => "virNetworkSetAutostart", sig => "net, bool : unit" }, + + { name => "virStoragePoolFree", sig => "pool : free" }, + { name => "virStoragePoolDestroy", sig => "pool : free" }, + { name => "virStoragePoolLookupByName", + sig => "conn, string : pool" }, + { name => "virStoragePoolLookupByUUID", + sig => "conn, uuid : pool" }, + { name => "virStoragePoolLookupByUUIDString", + sig => "conn, string : pool" }, + { name => "virStoragePoolGetName", + sig => "pool : static string" }, + { name => "virStoragePoolGetXMLDesc", + sig => "pool, 0U : string" }, + { name => "virStoragePoolGetUUID", + sig => "pool : uuid" }, + { name => "virStoragePoolGetUUIDString", + sig => "pool : uuid string" }, + { name => "virStoragePoolCreateXML", + sig => "conn, string, 0U : pool" }, + { name => "virStoragePoolDefineXML", + sig => "conn, string, 0U : pool" }, + { name => "virStoragePoolBuild", + sig => "pool, uint : unit" }, + { name => "virStoragePoolUndefine", + sig => "pool : unit" }, + { name => "virStoragePoolCreate", + sig => "pool, 0U : unit" }, + { name => "virStoragePoolDelete", + sig => "pool, uint : unit" }, + { name => "virStoragePoolRefresh", + sig => "pool, 0U : unit" }, + { name => "virStoragePoolGetAutostart", + sig => "pool : bool" }, + { name => "virStoragePoolSetAutostart", + sig => "pool, bool : unit" }, + { name => "virStoragePoolNumOfVolumes", + sig => "pool : int" }, + { name => "virStoragePoolListVolumes", + sig => "pool, int : string array" }, + + { name => "virStorageVolFree", sig => "vol : free" }, + { name => "virStorageVolDelete", + sig => "vol, uint : unit" }, + { name => "virStorageVolLookupByName", + sig => "pool, string : vol from pool" }, + { name => "virStorageVolLookupByKey", + sig => "conn, string : vol" }, + { name => "virStorageVolLookupByPath", + sig => "conn, string : vol" }, + { name => "virStorageVolCreateXML", + sig => "pool, string, 0U : vol from pool" }, + { name => "virStorageVolGetXMLDesc", + sig => "vol, 0U : string" }, + { name => "virStorageVolGetPath", + sig => "vol : string" }, + { name => "virStorageVolGetKey", + sig => "vol : static string" }, + { name => "virStorageVolGetName", + sig => "vol : static string" }, + { name => "virStoragePoolLookupByVolume", + sig => "vol : pool from vol" }, + + { name => "virSecretFree", sig => "sec : free" }, + { name => "virSecretUndefine", sig => "sec : unit" }, + { name => "virSecretLookupByUUID", sig => "conn, uuid : sec" }, + { name => "virSecretLookupByUUIDString", sig => "conn, string : sec" }, + { name => "virSecretDefineXML", sig => "conn, string, 0 : sec" }, + { name => "virSecretGetUUID", sig => "sec : uuid" }, + { name => "virSecretGetUUIDString", sig => "sec : uuid string" }, + { name => "virSecretGetUsageType", sig => "sec : int" }, + { name => "virSecretGetUsageID", sig => "sec : static string" }, + { name => "virSecretGetXMLDesc", sig => "sec, 0 : string" }, + + ); + +# Functions we haven't implemented anywhere yet but which are mentioned +# in 'libvirt.ml'. +# +# We create stubs for these, but eventually they need to either be +# moved ^^^ so they are auto-generated, or implementations of them +# written in 'libvirt_c_oneoffs.c'. + +my @unimplemented = ( + ); + +#---------------------------------------------------------------------- + +# Open the output file. + +my $filename = "libvirt_c.c"; +open F, ">$filename" or die "$filename: $!"; + +# Write the prologue. + +print F <<'END'; +/* !!! WARNING WARNING WARNING WARNING WARNING WARNING WARNING !!! + * + * THIS FILE IS AUTOMATICALLY GENERATED BY 'generator.pl'. + * + * Any changes you make to this file may be overwritten. + */ + +/* OCaml bindings for libvirt. + * (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc. + * https://libvirt.org/ + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2 of the License, or (at your option) any later version, + * with the OCaml linking exception described in ../COPYING.LIB. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +#include "config.h" + +#include <stdio.h> +#include <stdlib.h> +#include <string.h> + +#include <libvirt/libvirt.h> +#include <libvirt/virterror.h> + +#include <caml/config.h> +#include <caml/alloc.h> +#include <caml/callback.h> +#include <caml/custom.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/misc.h> +#include <caml/mlvalues.h> +#include <caml/signals.h> + +#include "libvirt_c_prologue.c" + +#include "libvirt_c_oneoffs.c" + +END + +#---------------------------------------------------------------------- + +sub camel_case_to_underscores +{ + my $name = shift; + + $name =~ s/([A-Z][a-z]+|XML|URI|OS|UUID)/$1,/g; + my @subs = split (/,/, $name); + @subs = map { lc($_) } @subs; + join "_", @subs +} + +# Helper functions dealing with signatures. + +sub short_name_to_c_type +{ + local $_ = shift; + + if ($_ eq "conn") { "virConnectPtr" } + elsif ($_ eq "dom") { "virDomainPtr" } + elsif ($_ eq "net") { "virNetworkPtr" } + elsif ($_ eq "pool") { "virStoragePoolPtr" } + elsif ($_ eq "vol") { "virStorageVolPtr" } + elsif ($_ eq "sec") { "virSecretPtr" } + else { + die "unknown short name $_" + } +} + +# OCaml argument names. + +sub gen_arg_names +{ + my $sig = shift; + + if ($sig =~ /^(\w+) : string$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+) : static string$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+) : int$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+) : uuid$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+) : uuid string$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+) : bool$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+), bool : unit$/) { + ( "$1v", "bv" ) + } elsif ($sig eq "conn, int : int array") { + ( "connv", "iv" ) + } elsif ($sig =~ /^(\w+), int : string array$/) { + ( "$1v", "iv" ) + } elsif ($sig =~ /^(\w+), 0U? : string$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+), 0U? : unit$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+) : unit$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+) : free$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+), string : unit$/) { + ( "$1v", "strv" ) + } elsif ($sig =~ /^(\w+), string, 0U? : unit$/) { + ( "$1v", "strv" ) + } elsif ($sig =~ /^(\w+), string : (\w+)$/) { + ( "$1v", "strv" ) + } elsif ($sig =~ /^(\w+), string, 0U? : (\w+)$/) { + ( "$1v", "strv" ) + } elsif ($sig =~ /^(\w+), string, unsigned : (\w+)$/) { + ( "$1v", "strv", "uv" ) + } elsif ($sig =~ /^(\w+), u?int : (\w+)$/) { + ( "$1v", "iv" ) + } elsif ($sig =~ /^(\w+), uuid : (\w+)$/) { + ( "$1v", "uuidv" ) + } elsif ($sig =~ /^(\w+), 0U? : (\w+)$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+) : (\w+)$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+), string : (\w+) from \w+$/) { + ( "$1v", "strv" ) + } elsif ($sig =~ /^(\w+), string, 0U? : (\w+) from \w+$/) { + ( "$1v", "strv" ) + } elsif ($sig =~ /^(\w+), 0U? : (\w+) from \w+$/) { + ( "$1v" ) + } elsif ($sig =~ /^(\w+) : (\w+) from \w+$/) { + ( "$1v" ) + } else { + die "unknown signature $sig" + } +} + +# Unpack the first (object) argument. + +sub gen_unpack_args +{ + local $_ = shift; + + if ($_ eq "conn") { + "virConnectPtr conn = Connect_val (connv);" + } elsif ($_ eq "dom") { + "virDomainPtr dom = Domain_val (domv);" + } elsif ($_ eq "net") { + "virNetworkPtr net = Network_val (netv);" + } elsif ($_ eq "pool") { + "virStoragePoolPtr pool = Pool_val (poolv);" + } elsif ($_ eq "vol") { + "virStorageVolPtr vol = Volume_val (volv);" + } elsif ($_ eq "sec") { + "virSecretPtr sec = Secret_val (secv);" + } else { + die "unknown short name $_" + } +} + +# Pack the result if it's an object. + +sub gen_pack_result +{ + local $_ = shift; + + if ($_ eq "dom") { "rv = Val_domain (r, connv);" } + elsif ($_ eq "net") { "rv = Val_network (r, connv);" } + elsif ($_ eq "pool") { "rv = Val_pool (r, connv);" } + elsif ($_ eq "vol") { "rv = Val_volume (r, connv);" } + elsif ($_ eq "sec") { "rv = Val_secret (r, connv);" } + else { + die "unknown short name $_" + } +} + +sub gen_free_arg +{ + local $_ = shift; + + if ($_ eq "conn") { "Connect_val (connv) = NULL;" } + elsif ($_ eq "dom") { "Domain_val (domv) = NULL;" } + elsif ($_ eq "net") { "Network_val (netv) = NULL;" } + elsif ($_ eq "pool") { "Pool_val (poolv) = NULL;" } + elsif ($_ eq "vol") { "Volume_val (volv) = NULL;" } + elsif ($_ eq "sec") { "Secret_val (secv) = NULL;" } + else { + die "unknown short name $_" + } +} + +# Generate the C body for each signature (class of function). + +sub gen_c_code +{ + my $sig = shift; + my $c_name = shift; + + if ($sig =~ /^(\w+) : string$/) { + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + char *r; + + NONBLOCKING (r = $c_name ($1)); + CHECK_ERROR (!r, \"$c_name\"); + + rv = caml_copy_string (r); + free (r); + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+) : static string$/) { + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + const char *r; + + NONBLOCKING (r = $c_name ($1)); + CHECK_ERROR (!r, \"$c_name\"); + + rv = caml_copy_string (r); + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+) : int$/) { + "\ + " . gen_unpack_args ($1) . " + int r; + + NONBLOCKING (r = $c_name ($1)); + CHECK_ERROR (r == -1, \"$c_name\"); + + CAMLreturn (Val_int (r)); +" + } elsif ($sig =~ /^(\w+) : uuid$/) { + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + unsigned char uuid[VIR_UUID_BUFLEN]; + int r; + + NONBLOCKING (r = $c_name ($1, uuid)); + CHECK_ERROR (r == -1, \"$c_name\"); + + /* UUIDs are byte arrays with a fixed length. */ + rv = caml_alloc_string (VIR_UUID_BUFLEN); + memcpy (String_val (rv), uuid, VIR_UUID_BUFLEN); + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+) : uuid string$/) { + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + char uuid[VIR_UUID_STRING_BUFLEN]; + int r; + + NONBLOCKING (r = $c_name ($1, uuid)); + CHECK_ERROR (r == -1, \"$c_name\"); + + rv = caml_copy_string (uuid); + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+) : bool$/) { + "\ + " . gen_unpack_args ($1) . " + int r, b; + + NONBLOCKING (r = $c_name ($1, &b)); + CHECK_ERROR (r == -1, \"$c_name\"); + + CAMLreturn (b ? Val_true : Val_false); +" + } elsif ($sig =~ /^(\w+), bool : unit$/) { + "\ + " . gen_unpack_args ($1) . " + int r, b; + + b = bv == Val_true ? 1 : 0; + + NONBLOCKING (r = $c_name ($1, b)); + CHECK_ERROR (r == -1, \"$c_name\"); + + CAMLreturn (Val_unit); +" + } elsif ($sig eq "conn, int : int array") { + "\ + CAMLlocal1 (rv); + virConnectPtr conn = Connect_val (connv); + int i = Int_val (iv); + int *ids, r; + + /* Some libvirt List* functions still throw exceptions if i == 0, + * so catch that and return an empty array directly. This changes + * the semantics slightly (masking other failures) but it's + * unlikely anyone will care. RWMJ 2008/06/10 + */ + if (i == 0) { + rv = caml_alloc (0, 0); + CAMLreturn (rv); + } + + ids = malloc (sizeof (*ids) * i); + if (ids == NULL) + caml_raise_out_of_memory (); + + NONBLOCKING (r = $c_name (conn, ids, i)); + CHECK_ERROR_CLEANUP (r == -1, free (ids), \"$c_name\"); + + rv = caml_alloc (r, 0); + for (i = 0; i < r; ++i) + Store_field (rv, i, Val_int (ids[i])); + free (ids); + + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+), int : string array$/) { + "\ + CAMLlocal2 (rv, strv); + " . gen_unpack_args ($1) . " + int i = Int_val (iv); + char **names; + int r; + + /* Some libvirt List* functions still throw exceptions if i == 0, + * so catch that and return an empty array directly. This changes + * the semantics slightly (masking other failures) but it's + * unlikely anyone will care. RWMJ 2008/06/10 + */ + if (i == 0) { + rv = caml_alloc (0, 0); + CAMLreturn (rv); + } + + names = malloc (sizeof (*names) * i); + if (names == NULL) + caml_raise_out_of_memory (); + + NONBLOCKING (r = $c_name ($1, names, i)); + CHECK_ERROR_CLEANUP (r == -1, free (names), \"$c_name\"); + + rv = caml_alloc (r, 0); + for (i = 0; i < r; ++i) { + strv = caml_copy_string (names[i]); + Store_field (rv, i, strv); + free (names[i]); + } + free (names); + + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+), 0U? : string$/) { + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + char *r; + + NONBLOCKING (r = $c_name ($1, 0)); + CHECK_ERROR (!r, \"$c_name\"); + + rv = caml_copy_string (r); + free (r); + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+), 0U? : unit$/) { + "\ + " . gen_unpack_args ($1) . " + int r; + + NONBLOCKING (r = $c_name ($1, 0)); + CHECK_ERROR (r == -1, \"$c_name\"); + + CAMLreturn (Val_unit); +" + } elsif ($sig =~ /^(\w+) : unit$/) { + "\ + " . gen_unpack_args ($1) . " + int r; + + NONBLOCKING (r = $c_name ($1)); + CHECK_ERROR (r == -1, \"$c_name\"); + + CAMLreturn (Val_unit); +" + } elsif ($sig =~ /^(\w+) : free$/) { + "\ + " . gen_unpack_args ($1) . " + int r; + + NONBLOCKING (r = $c_name ($1)); + CHECK_ERROR (r == -1, \"$c_name\"); + + /* So that we don't double-free in the finalizer: */ + " . gen_free_arg ($1) . " + + CAMLreturn (Val_unit); +" + } elsif ($sig =~ /^(\w+), string : unit$/) { + "\ + " . gen_unpack_args ($1) . " + char *str = String_val (strv); + int r; + + NONBLOCKING (r = $c_name ($1, str)); + CHECK_ERROR (r == -1, \"$c_name\"); + + CAMLreturn (Val_unit); +" + } elsif ($sig =~ /^(\w+), string, 0U? : unit$/) { + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + char *str = String_val (strv); + int r; + + NONBLOCKING (r = $c_name ($1, str, 0)); + CHECK_ERROR (!r, \"$c_name\"); + + CAMLreturn (Val_unit); +" + } elsif ($sig =~ /^(\w+), string : (\w+)$/) { + my $c_ret_type = short_name_to_c_type ($2); + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + char *str = String_val (strv); + $c_ret_type r; + + NONBLOCKING (r = $c_name ($1, str)); + CHECK_ERROR (!r, \"$c_name\"); + + " . gen_pack_result ($2) . " + + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+), string, 0U? : (\w+)$/) { + my $c_ret_type = short_name_to_c_type ($2); + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + char *str = String_val (strv); + $c_ret_type r; + + NONBLOCKING (r = $c_name ($1, str, 0)); + CHECK_ERROR (!r, \"$c_name\"); + + " . gen_pack_result ($2) . " + + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+), string, unsigned : (\w+)$/) { + my $c_ret_type = short_name_to_c_type ($2); + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + char *str = String_val (strv); + unsigned int u = Int_val (uv); + $c_ret_type r; + + NONBLOCKING (r = $c_name ($1, str, u)); + CHECK_ERROR (!r, \"$c_name\"); + + " . gen_pack_result ($2) . " + + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+), (u?)int : unit$/) { + my $unsigned = $2 eq "u" ? "unsigned " : ""; + "\ + " . gen_unpack_args ($1) . " + ${unsigned}int i = Int_val (iv); + int r; + + NONBLOCKING (r = $c_name ($1, i)); + CHECK_ERROR (r == -1, \"$c_name\"); + + CAMLreturn (Val_unit); +" + } elsif ($sig =~ /^(\w+), (u?)int : (\w+)$/) { + my $c_ret_type = short_name_to_c_type ($3); + my $unsigned = $2 eq "u" ? "unsigned " : ""; + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + ${unsigned}int i = Int_val (iv); + $c_ret_type r; + + NONBLOCKING (r = $c_name ($1, i)); + CHECK_ERROR (!r, \"$c_name\"); + + " . gen_pack_result ($3) . " + + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+), uuid : (\w+)$/) { + my $c_ret_type = short_name_to_c_type ($2); + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + unsigned char *uuid = (unsigned char *) String_val (uuidv); + $c_ret_type r; + + NONBLOCKING (r = $c_name ($1, uuid)); + CHECK_ERROR (!r, \"$c_name\"); + + " . gen_pack_result ($2) . " + + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+), 0U? : (\w+)$/) { + my $c_ret_type = short_name_to_c_type ($2); + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + $c_ret_type r; + + NONBLOCKING (r = $c_name ($1, 0)); + CHECK_ERROR (!r, \"$c_name\"); + + " . gen_pack_result ($2) . " + + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+) : (\w+)$/) { + my $c_ret_type = short_name_to_c_type ($2); + "\ + CAMLlocal1 (rv); + " . gen_unpack_args ($1) . " + $c_ret_type r; + + NONBLOCKING (r = $c_name ($1)); + CHECK_ERROR (!r, \"$c_name\"); + + " . gen_pack_result ($2) . " + + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+), string : (\w+) from (\w+)$/) { + my $c_ret_type = short_name_to_c_type ($2); + "\ + CAMLlocal2 (rv, connv); + " . gen_unpack_args ($1) . " + char *str = String_val (strv); + $c_ret_type r; + + NONBLOCKING (r = $c_name ($1, str)); + CHECK_ERROR (!r, \"$c_name\"); + + connv = Field ($3v, 1); + " . gen_pack_result ($2) . " + + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+), string, 0U? : (\w+) from (\w+)$/) { + my $c_ret_type = short_name_to_c_type ($2); + "\ + CAMLlocal2 (rv, connv); + " . gen_unpack_args ($1) . " + char *str = String_val (strv); + $c_ret_type r; + + NONBLOCKING (r = $c_name ($1, str, 0)); + CHECK_ERROR (!r, \"$c_name\"); + + connv = Field ($3v, 1); + " . gen_pack_result ($2) . " + + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+), 0U? : (\w+) from (\w+)$/) { + my $c_ret_type = short_name_to_c_type ($2); + "\ + CAMLlocal2 (rv, connv); + " . gen_unpack_args ($1) . " + $c_ret_type r; + + NONBLOCKING (r = $c_name ($1, 0)); + CHECK_ERROR (!r, \"$c_name\"); + + connv = Field ($3v, 1); + " . gen_pack_result ($2) . " + + CAMLreturn (rv); +" + } elsif ($sig =~ /^(\w+) : (\w+) from (\w+)$/) { + my $c_ret_type = short_name_to_c_type ($2); + "\ + CAMLlocal2 (rv, connv); + " . gen_unpack_args ($1) . " + $c_ret_type r; + + NONBLOCKING (r = $c_name ($1)); + CHECK_ERROR (!r, \"$c_name\"); + + connv = Field ($3v, 1); + " . gen_pack_result ($2) . " + + CAMLreturn (rv); +" + } else { + die "unknown signature $sig" + } +} + +# Generate each function. + +foreach my $function (@functions) { + my $c_name = $function->{name}; + my $sig = $function->{sig}; + + #print "generating $c_name with sig \"$sig\" ...\n"; + + #my $is_pool_func = $c_name =~ /^virStoragePool/; + #my $is_vol_func = $c_name =~ /^virStorageVol/; + + # Generate an equivalent C-external name for the function, unless + # one is defined already. + my $c_external_name; + if (exists ($function->{c_external_name})) { + $c_external_name = $function->{c_external_name}; + } elsif ($c_name =~ /^vir/) { + $c_external_name = substr $c_name, 3; + $c_external_name = camel_case_to_underscores ($c_external_name); + $c_external_name = "ocaml_libvirt_" . $c_external_name; + } else { + die "cannot convert c_name $c_name to c_external_name" + } + + print F <<END; +/* Automatically generated binding for $c_name. + * In generator.pl this function has signature "$sig". + */ + +END + + my @arg_names = gen_arg_names ($sig); + my $nr_arg_names = scalar @arg_names; + my $arg_names = join ", ", @arg_names; + my $arg_names_as_values = join (", ", map { "value $_" } @arg_names); + + # Generate the start of the function, arguments. + print F <<END; +CAMLprim value +$c_external_name ($arg_names_as_values) +{ + CAMLparam$nr_arg_names ($arg_names); +END + + # Generate the internals of the function. + print F (gen_c_code ($sig, $c_name)); + + # Finish off the function. + print F <<END; +} + +END +} + +#---------------------------------------------------------------------- + +# Unimplemented functions. + +if (@unimplemented) { + printf "$0: warning: %d unimplemented functions\n", scalar (@unimplemented); + + print F <<'END'; +/* The following functions are unimplemented and always fail. + * See generator.pl '@unimplemented' + */ + +END + + foreach my $c_external_name (@unimplemented) { + print F <<END; +CAMLprim value +$c_external_name () +{ + failwith ("$c_external_name is unimplemented"); +} + +END + } # end foreach +} # end if @unimplemented + +#---------------------------------------------------------------------- + +# Write the epilogue. + +print F <<'END'; +#include "libvirt_c_epilogue.c" + +/* EOF */ +END + +close F; +print "$0: written $filename\n" + diff --git a/common/mllibvirt/libvirt.README b/common/mllibvirt/libvirt.README new file mode 100644 index 000000000..a151bbc6b --- /dev/null +++ b/common/mllibvirt/libvirt.README @@ -0,0 +1,9 @@ +The files generator.pl, libvirt_c_epilogue.c, libvirt_c_oneoffs.c, +libvirt_c_prologue.c, libvirt.ml, and libvirt.mli come from the +ocaml-libvirt library: + + https://libvirt.org/git/?p=libvirt-ocaml.git + +which is released under a compatible license. We try to keep them +identical, so if you make changes to these files then you must also +submit the changes to ocaml-libvirt, and vice versa. diff --git a/common/mllibvirt/libvirt.ml b/common/mllibvirt/libvirt.ml new file mode 100644 index 000000000..49ccc3eaf --- /dev/null +++ b/common/mllibvirt/libvirt.ml @@ -0,0 +1,1661 @@ +(* OCaml bindings for libvirt. + (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc. + https://libvirt.org/ + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version, + with the OCaml linking exception described in ../COPYING.LIB. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +*) + +type uuid = string + +type xml = string + +type filename = string + +external get_version : ?driver:string -> unit -> int * int = "ocaml_libvirt_get_version" + +let uuid_length = 16 +let uuid_string_length = 36 + +(* https://caml.inria.fr/pub/ml-archives/caml-list/2004/07/80683af867cce6bf8... *) +type rw = [`R|`W] +type ro = [`R] + +module Connect = +struct + type 'rw t + + type node_info = { + model : string; + memory : int64; + cpus : int; + mhz : int; + nodes : int; + sockets : int; + cores : int; + threads : int; + } + + type credential_type = + | CredentialUsername + | CredentialAuthname + | CredentialLanguage + | CredentialCnonce + | CredentialPassphrase + | CredentialEchoprompt + | CredentialNoechoprompt + | CredentialRealm + | CredentialExternal + + type credential = { + typ : credential_type; + prompt : string; + challenge : string option; + defresult : string option; + } + + type auth = { + credtype : credential_type list; + cb : (credential list -> string option list); + } + + type list_flag = + | ListNoState | ListRunning | ListBlocked + | ListPaused | ListShutdown | ListShutoff | ListCrashed + | ListActive + | ListInactive + | ListAll + + external connect : ?name:string -> unit -> rw t = "ocaml_libvirt_connect_open" + external connect_readonly : ?name:string -> unit -> ro t = "ocaml_libvirt_connect_open_readonly" + external connect_auth : ?name:string -> auth -> rw t = "ocaml_libvirt_connect_open_auth" + external connect_auth_readonly : ?name:string -> auth -> ro t = "ocaml_libvirt_connect_open_auth_readonly" + external close : [>`R] t -> unit = "ocaml_libvirt_connect_close" + external get_type : [>`R] t -> string = "ocaml_libvirt_connect_get_type" + external get_version : [>`R] t -> int = "ocaml_libvirt_connect_get_version" + external get_hostname : [>`R] t -> string = "ocaml_libvirt_connect_get_hostname" + external get_uri : [>`R] t -> string = "ocaml_libvirt_connect_get_uri" + external get_max_vcpus : [>`R] t -> ?type_:string -> unit -> int = "ocaml_libvirt_connect_get_max_vcpus" + external list_domains : [>`R] t -> int -> int array = "ocaml_libvirt_connect_list_domains" + external num_of_domains : [>`R] t -> int = "ocaml_libvirt_connect_num_of_domains" + external get_capabilities : [>`R] t -> xml = "ocaml_libvirt_connect_get_capabilities" + external num_of_defined_domains : [>`R] t -> int = "ocaml_libvirt_connect_num_of_defined_domains" + external list_defined_domains : [>`R] t -> int -> string array = "ocaml_libvirt_connect_list_defined_domains" + external num_of_networks : [>`R] t -> int = "ocaml_libvirt_connect_num_of_networks" + external list_networks : [>`R] t -> int -> string array = "ocaml_libvirt_connect_list_networks" + external num_of_defined_networks : [>`R] t -> int = "ocaml_libvirt_connect_num_of_defined_networks" + external list_defined_networks : [>`R] t -> int -> string array = "ocaml_libvirt_connect_list_defined_networks" + external num_of_pools : [>`R] t -> int = "ocaml_libvirt_connect_num_of_storage_pools" + external list_pools : [>`R] t -> int -> string array = "ocaml_libvirt_connect_list_storage_pools" + external num_of_defined_pools : [>`R] t -> int = "ocaml_libvirt_connect_num_of_defined_storage_pools" + external list_defined_pools : [>`R] t -> int -> string array = "ocaml_libvirt_connect_list_defined_storage_pools" + external num_of_secrets : [>`R] t -> int = "ocaml_libvirt_connect_num_of_secrets" + external list_secrets : [>`R] t -> int -> string array = "ocaml_libvirt_connect_list_secrets" + + external get_node_info : [>`R] t -> node_info = "ocaml_libvirt_connect_get_node_info" + external node_get_free_memory : [> `R] t -> int64 = "ocaml_libvirt_connect_node_get_free_memory" + external node_get_cells_free_memory : [> `R] t -> int -> int -> int64 array = "ocaml_libvirt_connect_node_get_cells_free_memory" + + (* See VIR_NODEINFO_MAXCPUS macro defined in <libvirt.h>. *) + let maxcpus_of_node_info { nodes = nodes; sockets = sockets; + cores = cores; threads = threads } = + nodes * sockets * cores * threads + + (* See VIR_CPU_MAPLEN macro defined in <libvirt.h>. *) + let cpumaplen nr_cpus = + (nr_cpus + 7) / 8 + + (* See VIR_USE_CPU, VIR_UNUSE_CPU, VIR_CPU_USABLE macros defined in <libvirt.h>. *) + let use_cpu cpumap cpu = + Bytes.set cpumap (cpu/8) + (Char.chr (Char.code (Bytes.get cpumap (cpu/8)) lor (1 lsl (cpu mod 8)))) + let unuse_cpu cpumap cpu = + Bytes.set cpumap (cpu/8) + (Char.chr (Char.code (Bytes.get cpumap (cpu/8)) land (lnot (1 lsl (cpu mod 8))))) + let cpu_usable cpumaps maplen vcpu cpu = + Char.code (Bytes.get cpumaps (vcpu*maplen + cpu/8)) land (1 lsl (cpu mod 8)) <> 0 + + external set_keep_alive : [>`R] t -> int -> int -> unit = "ocaml_libvirt_connect_set_keep_alive" + + (* Internal API needed for get_auth_default. *) + external _credtypes_from_auth_default : unit -> credential_type list = "ocaml_libvirt_connect_credtypes_from_auth_default" + external _call_auth_default_callback : credential list -> string option list = "ocaml_libvirt_connect_call_auth_default_callback" + let get_auth_default () = + { + credtype = _credtypes_from_auth_default (); + cb = _call_auth_default_callback; + } + + external const : [>`R] t -> ro t = "%identity" +end + +module Virterror = +struct + type code = + | VIR_ERR_OK + | VIR_ERR_INTERNAL_ERROR + | VIR_ERR_NO_MEMORY + | VIR_ERR_NO_SUPPORT + | VIR_ERR_UNKNOWN_HOST + | VIR_ERR_NO_CONNECT + | VIR_ERR_INVALID_CONN + | VIR_ERR_INVALID_DOMAIN + | VIR_ERR_INVALID_ARG + | VIR_ERR_OPERATION_FAILED + | VIR_ERR_GET_FAILED + | VIR_ERR_POST_FAILED + | VIR_ERR_HTTP_ERROR + | VIR_ERR_SEXPR_SERIAL + | VIR_ERR_NO_XEN + | VIR_ERR_XEN_CALL + | VIR_ERR_OS_TYPE + | VIR_ERR_NO_KERNEL + | VIR_ERR_NO_ROOT + | VIR_ERR_NO_SOURCE + | VIR_ERR_NO_TARGET + | VIR_ERR_NO_NAME + | VIR_ERR_NO_OS + | VIR_ERR_NO_DEVICE + | VIR_ERR_NO_XENSTORE + | VIR_ERR_DRIVER_FULL + | VIR_ERR_CALL_FAILED + | VIR_ERR_XML_ERROR + | VIR_ERR_DOM_EXIST + | VIR_ERR_OPERATION_DENIED + | VIR_ERR_OPEN_FAILED + | VIR_ERR_READ_FAILED + | VIR_ERR_PARSE_FAILED + | VIR_ERR_CONF_SYNTAX + | VIR_ERR_WRITE_FAILED + | VIR_ERR_XML_DETAIL + | VIR_ERR_INVALID_NETWORK + | VIR_ERR_NETWORK_EXIST + | VIR_ERR_SYSTEM_ERROR + | VIR_ERR_RPC + | VIR_ERR_GNUTLS_ERROR + | VIR_WAR_NO_NETWORK + | VIR_ERR_NO_DOMAIN + | VIR_ERR_NO_NETWORK + | VIR_ERR_INVALID_MAC + | VIR_ERR_AUTH_FAILED + | VIR_ERR_INVALID_STORAGE_POOL + | VIR_ERR_INVALID_STORAGE_VOL + | VIR_WAR_NO_STORAGE + | VIR_ERR_NO_STORAGE_POOL + | VIR_ERR_NO_STORAGE_VOL + | VIR_WAR_NO_NODE + | VIR_ERR_INVALID_NODE_DEVICE + | VIR_ERR_NO_NODE_DEVICE + | VIR_ERR_NO_SECURITY_MODEL + | VIR_ERR_OPERATION_INVALID + | VIR_WAR_NO_INTERFACE + | VIR_ERR_NO_INTERFACE + | VIR_ERR_INVALID_INTERFACE + | VIR_ERR_MULTIPLE_INTERFACES + | VIR_WAR_NO_NWFILTER + | VIR_ERR_INVALID_NWFILTER + | VIR_ERR_NO_NWFILTER + | VIR_ERR_BUILD_FIREWALL + | VIR_WAR_NO_SECRET + | VIR_ERR_INVALID_SECRET + | VIR_ERR_NO_SECRET + | VIR_ERR_CONFIG_UNSUPPORTED + | VIR_ERR_OPERATION_TIMEOUT + | VIR_ERR_MIGRATE_PERSIST_FAILED + | VIR_ERR_HOOK_SCRIPT_FAILED + | VIR_ERR_INVALID_DOMAIN_SNAPSHOT + | VIR_ERR_NO_DOMAIN_SNAPSHOT + | VIR_ERR_INVALID_STREAM + | VIR_ERR_ARGUMENT_UNSUPPORTED + | VIR_ERR_STORAGE_PROBE_FAILED + | VIR_ERR_STORAGE_POOL_BUILT + | VIR_ERR_SNAPSHOT_REVERT_RISKY + | VIR_ERR_OPERATION_ABORTED + | VIR_ERR_AUTH_CANCELLED + | VIR_ERR_NO_DOMAIN_METADATA + | VIR_ERR_MIGRATE_UNSAFE + | VIR_ERR_OVERFLOW + | VIR_ERR_BLOCK_COPY_ACTIVE + | VIR_ERR_OPERATION_UNSUPPORTED + | VIR_ERR_SSH + | VIR_ERR_AGENT_UNRESPONSIVE + | VIR_ERR_RESOURCE_BUSY + | VIR_ERR_ACCESS_DENIED + | VIR_ERR_DBUS_SERVICE + | VIR_ERR_STORAGE_VOL_EXIST + | VIR_ERR_CPU_INCOMPATIBLE + | VIR_ERR_XML_INVALID_SCHEMA + | VIR_ERR_MIGRATE_FINISH_OK + | VIR_ERR_AUTH_UNAVAILABLE + | VIR_ERR_NO_SERVER + | VIR_ERR_NO_CLIENT + | VIR_ERR_AGENT_UNSYNCED + | VIR_ERR_LIBSSH + | VIR_ERR_DEVICE_MISSING + | VIR_ERR_INVALID_NWFILTER_BINDING + | VIR_ERR_NO_NWFILTER_BINDING + | VIR_ERR_UNKNOWN of int + + let string_of_code = function + | VIR_ERR_OK -> "VIR_ERR_OK" + | VIR_ERR_INTERNAL_ERROR -> "VIR_ERR_INTERNAL_ERROR" + | VIR_ERR_NO_MEMORY -> "VIR_ERR_NO_MEMORY" + | VIR_ERR_NO_SUPPORT -> "VIR_ERR_NO_SUPPORT" + | VIR_ERR_UNKNOWN_HOST -> "VIR_ERR_UNKNOWN_HOST" + | VIR_ERR_NO_CONNECT -> "VIR_ERR_NO_CONNECT" + | VIR_ERR_INVALID_CONN -> "VIR_ERR_INVALID_CONN" + | VIR_ERR_INVALID_DOMAIN -> "VIR_ERR_INVALID_DOMAIN" + | VIR_ERR_INVALID_ARG -> "VIR_ERR_INVALID_ARG" + | VIR_ERR_OPERATION_FAILED -> "VIR_ERR_OPERATION_FAILED" + | VIR_ERR_GET_FAILED -> "VIR_ERR_GET_FAILED" + | VIR_ERR_POST_FAILED -> "VIR_ERR_POST_FAILED" + | VIR_ERR_HTTP_ERROR -> "VIR_ERR_HTTP_ERROR" + | VIR_ERR_SEXPR_SERIAL -> "VIR_ERR_SEXPR_SERIAL" + | VIR_ERR_NO_XEN -> "VIR_ERR_NO_XEN" + | VIR_ERR_XEN_CALL -> "VIR_ERR_XEN_CALL" + | VIR_ERR_OS_TYPE -> "VIR_ERR_OS_TYPE" + | VIR_ERR_NO_KERNEL -> "VIR_ERR_NO_KERNEL" + | VIR_ERR_NO_ROOT -> "VIR_ERR_NO_ROOT" + | VIR_ERR_NO_SOURCE -> "VIR_ERR_NO_SOURCE" + | VIR_ERR_NO_TARGET -> "VIR_ERR_NO_TARGET" + | VIR_ERR_NO_NAME -> "VIR_ERR_NO_NAME" + | VIR_ERR_NO_OS -> "VIR_ERR_NO_OS" + | VIR_ERR_NO_DEVICE -> "VIR_ERR_NO_DEVICE" + | VIR_ERR_NO_XENSTORE -> "VIR_ERR_NO_XENSTORE" + | VIR_ERR_DRIVER_FULL -> "VIR_ERR_DRIVER_FULL" + | VIR_ERR_CALL_FAILED -> "VIR_ERR_CALL_FAILED" + | VIR_ERR_XML_ERROR -> "VIR_ERR_XML_ERROR" + | VIR_ERR_DOM_EXIST -> "VIR_ERR_DOM_EXIST" + | VIR_ERR_OPERATION_DENIED -> "VIR_ERR_OPERATION_DENIED" + | VIR_ERR_OPEN_FAILED -> "VIR_ERR_OPEN_FAILED" + | VIR_ERR_READ_FAILED -> "VIR_ERR_READ_FAILED" + | VIR_ERR_PARSE_FAILED -> "VIR_ERR_PARSE_FAILED" + | VIR_ERR_CONF_SYNTAX -> "VIR_ERR_CONF_SYNTAX" + | VIR_ERR_WRITE_FAILED -> "VIR_ERR_WRITE_FAILED" + | VIR_ERR_XML_DETAIL -> "VIR_ERR_XML_DETAIL" + | VIR_ERR_INVALID_NETWORK -> "VIR_ERR_INVALID_NETWORK" + | VIR_ERR_NETWORK_EXIST -> "VIR_ERR_NETWORK_EXIST" + | VIR_ERR_SYSTEM_ERROR -> "VIR_ERR_SYSTEM_ERROR" + | VIR_ERR_RPC -> "VIR_ERR_RPC" + | VIR_ERR_GNUTLS_ERROR -> "VIR_ERR_GNUTLS_ERROR" + | VIR_WAR_NO_NETWORK -> "VIR_WAR_NO_NETWORK" + | VIR_ERR_NO_DOMAIN -> "VIR_ERR_NO_DOMAIN" + | VIR_ERR_NO_NETWORK -> "VIR_ERR_NO_NETWORK" + | VIR_ERR_INVALID_MAC -> "VIR_ERR_INVALID_MAC" + | VIR_ERR_AUTH_FAILED -> "VIR_ERR_AUTH_FAILED" + | VIR_ERR_INVALID_STORAGE_POOL -> "VIR_ERR_INVALID_STORAGE_POOL" + | VIR_ERR_INVALID_STORAGE_VOL -> "VIR_ERR_INVALID_STORAGE_VOL" + | VIR_WAR_NO_STORAGE -> "VIR_WAR_NO_STORAGE" + | VIR_ERR_NO_STORAGE_POOL -> "VIR_ERR_NO_STORAGE_POOL" + | VIR_ERR_NO_STORAGE_VOL -> "VIR_ERR_NO_STORAGE_VOL" + | VIR_WAR_NO_NODE -> "VIR_WAR_NO_NODE" + | VIR_ERR_INVALID_NODE_DEVICE -> "VIR_ERR_INVALID_NODE_DEVICE" + | VIR_ERR_NO_NODE_DEVICE -> "VIR_ERR_NO_NODE_DEVICE" + | VIR_ERR_NO_SECURITY_MODEL -> "VIR_ERR_NO_SECURITY_MODEL" + | VIR_ERR_OPERATION_INVALID -> "VIR_ERR_OPERATION_INVALID" + | VIR_WAR_NO_INTERFACE -> "VIR_WAR_NO_INTERFACE" + | VIR_ERR_NO_INTERFACE -> "VIR_ERR_NO_INTERFACE" + | VIR_ERR_INVALID_INTERFACE -> "VIR_ERR_INVALID_INTERFACE" + | VIR_ERR_MULTIPLE_INTERFACES -> "VIR_ERR_MULTIPLE_INTERFACES" + | VIR_WAR_NO_NWFILTER -> "VIR_WAR_NO_NWFILTER" + | VIR_ERR_INVALID_NWFILTER -> "VIR_ERR_INVALID_NWFILTER" + | VIR_ERR_NO_NWFILTER -> "VIR_ERR_NO_NWFILTER" + | VIR_ERR_BUILD_FIREWALL -> "VIR_ERR_BUILD_FIREWALL" + | VIR_WAR_NO_SECRET -> "VIR_WAR_NO_SECRET" + | VIR_ERR_INVALID_SECRET -> "VIR_ERR_INVALID_SECRET" + | VIR_ERR_NO_SECRET -> "VIR_ERR_NO_SECRET" + | VIR_ERR_CONFIG_UNSUPPORTED -> "VIR_ERR_CONFIG_UNSUPPORTED" + | VIR_ERR_OPERATION_TIMEOUT -> "VIR_ERR_OPERATION_TIMEOUT" + | VIR_ERR_MIGRATE_PERSIST_FAILED -> "VIR_ERR_MIGRATE_PERSIST_FAILED" + | VIR_ERR_HOOK_SCRIPT_FAILED -> "VIR_ERR_HOOK_SCRIPT_FAILED" + | VIR_ERR_INVALID_DOMAIN_SNAPSHOT -> "VIR_ERR_INVALID_DOMAIN_SNAPSHOT" + | VIR_ERR_NO_DOMAIN_SNAPSHOT -> "VIR_ERR_NO_DOMAIN_SNAPSHOT" + | VIR_ERR_INVALID_STREAM -> "VIR_ERR_INVALID_STREAM" + | VIR_ERR_ARGUMENT_UNSUPPORTED -> "VIR_ERR_ARGUMENT_UNSUPPORTED" + | VIR_ERR_STORAGE_PROBE_FAILED -> "VIR_ERR_STORAGE_PROBE_FAILED" + | VIR_ERR_STORAGE_POOL_BUILT -> "VIR_ERR_STORAGE_POOL_BUILT" + | VIR_ERR_SNAPSHOT_REVERT_RISKY -> "VIR_ERR_SNAPSHOT_REVERT_RISKY" + | VIR_ERR_OPERATION_ABORTED -> "VIR_ERR_OPERATION_ABORTED" + | VIR_ERR_AUTH_CANCELLED -> "VIR_ERR_AUTH_CANCELLED" + | VIR_ERR_NO_DOMAIN_METADATA -> "VIR_ERR_NO_DOMAIN_METADATA" + | VIR_ERR_MIGRATE_UNSAFE -> "VIR_ERR_MIGRATE_UNSAFE" + | VIR_ERR_OVERFLOW -> "VIR_ERR_OVERFLOW" + | VIR_ERR_BLOCK_COPY_ACTIVE -> "VIR_ERR_BLOCK_COPY_ACTIVE" + | VIR_ERR_OPERATION_UNSUPPORTED -> "VIR_ERR_OPERATION_UNSUPPORTED" + | VIR_ERR_SSH -> "VIR_ERR_SSH" + | VIR_ERR_AGENT_UNRESPONSIVE -> "VIR_ERR_AGENT_UNRESPONSIVE" + | VIR_ERR_RESOURCE_BUSY -> "VIR_ERR_RESOURCE_BUSY" + | VIR_ERR_ACCESS_DENIED -> "VIR_ERR_ACCESS_DENIED" + | VIR_ERR_DBUS_SERVICE -> "VIR_ERR_DBUS_SERVICE" + | VIR_ERR_STORAGE_VOL_EXIST -> "VIR_ERR_STORAGE_VOL_EXIST" + | VIR_ERR_CPU_INCOMPATIBLE -> "VIR_ERR_CPU_INCOMPATIBLE" + | VIR_ERR_XML_INVALID_SCHEMA -> "VIR_ERR_XML_INVALID_SCHEMA" + | VIR_ERR_MIGRATE_FINISH_OK -> "VIR_ERR_MIGRATE_FINISH_OK" + | VIR_ERR_AUTH_UNAVAILABLE -> "VIR_ERR_AUTH_UNAVAILABLE" + | VIR_ERR_NO_SERVER -> "VIR_ERR_NO_SERVER" + | VIR_ERR_NO_CLIENT -> "VIR_ERR_NO_CLIENT" + | VIR_ERR_AGENT_UNSYNCED -> "VIR_ERR_AGENT_UNSYNCED" + | VIR_ERR_LIBSSH -> "VIR_ERR_LIBSSH" + | VIR_ERR_DEVICE_MISSING -> "VIR_ERR_DEVICE_MISSING" + | VIR_ERR_INVALID_NWFILTER_BINDING -> "VIR_ERR_INVALID_NWFILTER_BINDING" + | VIR_ERR_NO_NWFILTER_BINDING -> "VIR_ERR_NO_NWFILTER_BINDING" + | VIR_ERR_UNKNOWN i -> "VIR_ERR_" ^ string_of_int i + + type domain = + | VIR_FROM_NONE + | VIR_FROM_XEN + | VIR_FROM_XEND + | VIR_FROM_XENSTORE + | VIR_FROM_SEXPR + | VIR_FROM_XML + | VIR_FROM_DOM + | VIR_FROM_RPC + | VIR_FROM_PROXY + | VIR_FROM_CONF + | VIR_FROM_QEMU + | VIR_FROM_NET + | VIR_FROM_TEST + | VIR_FROM_REMOTE + | VIR_FROM_OPENVZ + | VIR_FROM_XENXM + | VIR_FROM_STATS_LINUX + | VIR_FROM_LXC + | VIR_FROM_STORAGE + | VIR_FROM_NETWORK + | VIR_FROM_DOMAIN + | VIR_FROM_UML + | VIR_FROM_NODEDEV + | VIR_FROM_XEN_INOTIFY + | VIR_FROM_SECURITY + | VIR_FROM_VBOX + | VIR_FROM_INTERFACE + | VIR_FROM_ONE + | VIR_FROM_ESX + | VIR_FROM_PHYP + | VIR_FROM_SECRET + | VIR_FROM_CPU + | VIR_FROM_XENAPI + | VIR_FROM_NWFILTER + | VIR_FROM_HOOK + | VIR_FROM_DOMAIN_SNAPSHOT + | VIR_FROM_AUDIT + | VIR_FROM_SYSINFO + | VIR_FROM_STREAMS + | VIR_FROM_VMWARE + | VIR_FROM_EVENT + | VIR_FROM_LIBXL + | VIR_FROM_LOCKING + | VIR_FROM_HYPERV + | VIR_FROM_CAPABILITIES + | VIR_FROM_URI + | VIR_FROM_AUTH + | VIR_FROM_DBUS + | VIR_FROM_PARALLELS + | VIR_FROM_DEVICE + | VIR_FROM_SSH + | VIR_FROM_LOCKSPACE + | VIR_FROM_INITCTL + | VIR_FROM_IDENTITY + | VIR_FROM_CGROUP + | VIR_FROM_ACCESS + | VIR_FROM_SYSTEMD + | VIR_FROM_BHYVE + | VIR_FROM_CRYPTO + | VIR_FROM_FIREWALL + | VIR_FROM_POLKIT + | VIR_FROM_THREAD + | VIR_FROM_ADMIN + | VIR_FROM_LOGGING + | VIR_FROM_XENXL + | VIR_FROM_PERF + | VIR_FROM_LIBSSH + | VIR_FROM_RESCTRL + | VIR_FROM_UNKNOWN of int + + let string_of_domain = function + | VIR_FROM_NONE -> "VIR_FROM_NONE" + | VIR_FROM_XEN -> "VIR_FROM_XEN" + | VIR_FROM_XEND -> "VIR_FROM_XEND" + | VIR_FROM_XENSTORE -> "VIR_FROM_XENSTORE" + | VIR_FROM_SEXPR -> "VIR_FROM_SEXPR" + | VIR_FROM_XML -> "VIR_FROM_XML" + | VIR_FROM_DOM -> "VIR_FROM_DOM" + | VIR_FROM_RPC -> "VIR_FROM_RPC" + | VIR_FROM_PROXY -> "VIR_FROM_PROXY" + | VIR_FROM_CONF -> "VIR_FROM_CONF" + | VIR_FROM_QEMU -> "VIR_FROM_QEMU" + | VIR_FROM_NET -> "VIR_FROM_NET" + | VIR_FROM_TEST -> "VIR_FROM_TEST" + | VIR_FROM_REMOTE -> "VIR_FROM_REMOTE" + | VIR_FROM_OPENVZ -> "VIR_FROM_OPENVZ" + | VIR_FROM_XENXM -> "VIR_FROM_XENXM" + | VIR_FROM_STATS_LINUX -> "VIR_FROM_STATS_LINUX" + | VIR_FROM_LXC -> "VIR_FROM_LXC" + | VIR_FROM_STORAGE -> "VIR_FROM_STORAGE" + | VIR_FROM_NETWORK -> "VIR_FROM_NETWORK" + | VIR_FROM_DOMAIN -> "VIR_FROM_DOMAIN" + | VIR_FROM_UML -> "VIR_FROM_UML" + | VIR_FROM_NODEDEV -> "VIR_FROM_NODEDEV" + | VIR_FROM_XEN_INOTIFY -> "VIR_FROM_XEN_INOTIFY" + | VIR_FROM_SECURITY -> "VIR_FROM_SECURITY" + | VIR_FROM_VBOX -> "VIR_FROM_VBOX" + | VIR_FROM_INTERFACE -> "VIR_FROM_INTERFACE" + | VIR_FROM_ONE -> "VIR_FROM_ONE" + | VIR_FROM_ESX -> "VIR_FROM_ESX" + | VIR_FROM_PHYP -> "VIR_FROM_PHYP" + | VIR_FROM_SECRET -> "VIR_FROM_SECRET" + | VIR_FROM_CPU -> "VIR_FROM_CPU" + | VIR_FROM_XENAPI -> "VIR_FROM_XENAPI" + | VIR_FROM_NWFILTER -> "VIR_FROM_NWFILTER" + | VIR_FROM_HOOK -> "VIR_FROM_HOOK" + | VIR_FROM_DOMAIN_SNAPSHOT -> "VIR_FROM_DOMAIN_SNAPSHOT" + | VIR_FROM_AUDIT -> "VIR_FROM_AUDIT" + | VIR_FROM_SYSINFO -> "VIR_FROM_SYSINFO" + | VIR_FROM_STREAMS -> "VIR_FROM_STREAMS" + | VIR_FROM_VMWARE -> "VIR_FROM_VMWARE" + | VIR_FROM_EVENT -> "VIR_FROM_EVENT" + | VIR_FROM_LIBXL -> "VIR_FROM_LIBXL" + | VIR_FROM_LOCKING -> "VIR_FROM_LOCKING" + | VIR_FROM_HYPERV -> "VIR_FROM_HYPERV" + | VIR_FROM_CAPABILITIES -> "VIR_FROM_CAPABILITIES" + | VIR_FROM_URI -> "VIR_FROM_URI" + | VIR_FROM_AUTH -> "VIR_FROM_AUTH" + | VIR_FROM_DBUS -> "VIR_FROM_DBUS" + | VIR_FROM_PARALLELS -> "VIR_FROM_PARALLELS" + | VIR_FROM_DEVICE -> "VIR_FROM_DEVICE" + | VIR_FROM_SSH -> "VIR_FROM_SSH" + | VIR_FROM_LOCKSPACE -> "VIR_FROM_LOCKSPACE" + | VIR_FROM_INITCTL -> "VIR_FROM_INITCTL" + | VIR_FROM_IDENTITY -> "VIR_FROM_IDENTITY" + | VIR_FROM_CGROUP -> "VIR_FROM_CGROUP" + | VIR_FROM_ACCESS -> "VIR_FROM_ACCESS" + | VIR_FROM_SYSTEMD -> "VIR_FROM_SYSTEMD" + | VIR_FROM_BHYVE -> "VIR_FROM_BHYVE" + | VIR_FROM_CRYPTO -> "VIR_FROM_CRYPTO" + | VIR_FROM_FIREWALL -> "VIR_FROM_FIREWALL" + | VIR_FROM_POLKIT -> "VIR_FROM_POLKIT" + | VIR_FROM_THREAD -> "VIR_FROM_THREAD" + | VIR_FROM_ADMIN -> "VIR_FROM_ADMIN" + | VIR_FROM_LOGGING -> "VIR_FROM_LOGGING" + | VIR_FROM_XENXL -> "VIR_FROM_XENXL" + | VIR_FROM_PERF -> "VIR_FROM_PERF" + | VIR_FROM_LIBSSH -> "VIR_FROM_LIBSSH" + | VIR_FROM_RESCTRL -> "VIR_FROM_RESCTRL" + | VIR_FROM_UNKNOWN i -> "VIR_FROM_" ^ string_of_int i + + type level = + | VIR_ERR_NONE + | VIR_ERR_WARNING + | VIR_ERR_ERROR + | VIR_ERR_UNKNOWN_LEVEL of int + + let string_of_level = function + | VIR_ERR_NONE -> "VIR_ERR_NONE" + | VIR_ERR_WARNING -> "VIR_ERR_WARNING" + | VIR_ERR_ERROR -> "VIR_ERR_ERROR" + | VIR_ERR_UNKNOWN_LEVEL i -> "VIR_ERR_LEVEL_" ^ string_of_int i + + type t = { + code : code; + domain : domain; + message : string option; + level : level; + str1 : string option; + str2 : string option; + str3 : string option; + int1 : int32; + int2 : int32; + } + + let to_string { code = code; domain = domain; message = message } = + let buf = Buffer.create 128 in + Buffer.add_string buf "libvirt: "; + Buffer.add_string buf (string_of_code code); + Buffer.add_string buf ": "; + Buffer.add_string buf (string_of_domain domain); + Buffer.add_string buf ": "; + (match message with Some msg -> Buffer.add_string buf msg | None -> ()); + Buffer.contents buf + + external get_last_error : unit -> t option = "ocaml_libvirt_virterror_get_last_error" + external get_last_conn_error : [>`R] Connect.t -> t option = "ocaml_libvirt_virterror_get_last_conn_error" + external reset_last_error : unit -> unit = "ocaml_libvirt_virterror_reset_last_error" + external reset_last_conn_error : [>`R] Connect.t -> unit = "ocaml_libvirt_virterror_reset_last_conn_error" + + let no_error () = + { code = VIR_ERR_OK; domain = VIR_FROM_NONE; + message = None; level = VIR_ERR_NONE; + str1 = None; str2 = None; str3 = None; + int1 = 0_l; int2 = 0_l } +end + +exception Virterror of Virterror.t +exception Not_supported of string + +let rec map_ignore_errors f = function + | [] -> [] + | x :: xs -> + try f x :: map_ignore_errors f xs + with Virterror _ -> map_ignore_errors f xs + +module Domain = +struct + type 'rw t + + type state = + | InfoNoState | InfoRunning | InfoBlocked | InfoPaused + | InfoShutdown | InfoShutoff | InfoCrashed | InfoPMSuspended + + type info = { + state : state; + max_mem : int64; + memory : int64; + nr_virt_cpu : int; + cpu_time : int64; + } + + type vcpu_state = VcpuOffline | VcpuRunning | VcpuBlocked + + type vcpu_info = { + number : int; + vcpu_state : vcpu_state; + vcpu_time : int64; + cpu : int; + } + + type domain_create_flag = + | START_PAUSED + | START_AUTODESTROY + | START_BYPASS_CACHE + | START_FORCE_BOOT + | START_VALIDATE + let rec int_of_domain_create_flags = function + | [] -> 0 + | START_PAUSED :: flags -> 1 lor int_of_domain_create_flags flags + | START_AUTODESTROY :: flags -> 2 lor int_of_domain_create_flags flags + | START_BYPASS_CACHE :: flags -> 4 lor int_of_domain_create_flags flags + | START_FORCE_BOOT :: flags -> 8 lor int_of_domain_create_flags flags + | START_VALIDATE :: flags -> 16 lor int_of_domain_create_flags flags + + type sched_param = string * sched_param_value + and sched_param_value = + | SchedFieldInt32 of int32 | SchedFieldUInt32 of int32 + | SchedFieldInt64 of int64 | SchedFieldUInt64 of int64 + | SchedFieldFloat of float | SchedFieldBool of bool + + type typed_param = string * typed_param_value + and typed_param_value = + | TypedFieldInt32 of int32 | TypedFieldUInt32 of int32 + | TypedFieldInt64 of int64 | TypedFieldUInt64 of int64 + | TypedFieldFloat of float | TypedFieldBool of bool + | TypedFieldString of string + + type migrate_flag = Live + + type memory_flag = Virtual + + type list_flag = + | ListActive + | ListInactive + | ListAll + + type block_stats = { + rd_req : int64; + rd_bytes : int64; + wr_req : int64; + wr_bytes : int64; + errs : int64; + } + + type interface_stats = { + rx_bytes : int64; + rx_packets : int64; + rx_errs : int64; + rx_drop : int64; + tx_bytes : int64; + tx_packets : int64; + tx_errs : int64; + tx_drop : int64; + } + + type get_all_domain_stats_flag = + | GetAllDomainsStatsActive + | GetAllDomainsStatsInactive + | GetAllDomainsStatsOther + | GetAllDomainsStatsPaused + | GetAllDomainsStatsPersistent + | GetAllDomainsStatsRunning + | GetAllDomainsStatsShutoff + | GetAllDomainsStatsTransient + | GetAllDomainsStatsBacking + | GetAllDomainsStatsEnforceStats + + type stats_type = + | StatsState | StatsCpuTotal | StatsBalloon | StatsVcpu + | StatsInterface | StatsBlock | StatsPerf + + type domain_stats_record = { + dom_uuid : uuid; + params : typed_param array; + } + + type xml_desc_flag = + | XmlSecure + | XmlInactive + | XmlUpdateCPU + | XmlMigratable + + (* The maximum size for Domain.memory_peek and Domain.block_peek + * supported by libvirt. This may change with different versions + * of libvirt in the future, hence it's a function. + *) + let max_peek _ = 65536 + + external create_linux : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_domain_create_linux" + external _create_xml : [>`W] Connect.t -> xml -> int -> rw t = "ocaml_libvirt_domain_create_xml" + let create_xml conn xml flags = + _create_xml conn xml (int_of_domain_create_flags flags) + external lookup_by_id : 'a Connect.t -> int -> 'a t = "ocaml_libvirt_domain_lookup_by_id" + external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t = "ocaml_libvirt_domain_lookup_by_uuid" + external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_domain_lookup_by_uuid_string" + external lookup_by_name : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_domain_lookup_by_name" + external destroy : [>`W] t -> unit = "ocaml_libvirt_domain_destroy" + external free : [>`R] t -> unit = "ocaml_libvirt_domain_free" + external suspend : [>`W] t -> unit = "ocaml_libvirt_domain_suspend" + external resume : [>`W] t -> unit = "ocaml_libvirt_domain_resume" + external save : [>`W] t -> filename -> unit = "ocaml_libvirt_domain_save" + external restore : [>`W] Connect.t -> filename -> unit = "ocaml_libvirt_domain_restore" + external core_dump : [>`W] t -> filename -> unit = "ocaml_libvirt_domain_core_dump" + external shutdown : [>`W] t -> unit = "ocaml_libvirt_domain_shutdown" + external reboot : [>`W] t -> unit = "ocaml_libvirt_domain_reboot" + external get_name : [>`R] t -> string = "ocaml_libvirt_domain_get_name" + external get_uuid : [>`R] t -> uuid = "ocaml_libvirt_domain_get_uuid" + external get_uuid_string : [>`R] t -> string = "ocaml_libvirt_domain_get_uuid_string" + external get_id : [>`R] t -> int = "ocaml_libvirt_domain_get_id" + external get_os_type : [>`R] t -> string = "ocaml_libvirt_domain_get_os_type" + external get_max_memory : [>`R] t -> int64 = "ocaml_libvirt_domain_get_max_memory" + external set_max_memory : [>`W] t -> int64 -> unit = "ocaml_libvirt_domain_set_max_memory" + external set_memory : [>`W] t -> int64 -> unit = "ocaml_libvirt_domain_set_memory" + external get_info : [>`R] t -> info = "ocaml_libvirt_domain_get_info" + external get_xml_desc : [>`R] t -> xml = "ocaml_libvirt_domain_get_xml_desc" + external get_xml_desc_flags : [>`W] t -> xml_desc_flag list -> xml = "ocaml_libvirt_domain_get_xml_desc_flags" + external get_scheduler_type : [>`R] t -> string * int = "ocaml_libvirt_domain_get_scheduler_type" + external get_scheduler_parameters : [>`R] t -> int -> sched_param array = "ocaml_libvirt_domain_get_scheduler_parameters" + external set_scheduler_parameters : [>`W] t -> sched_param array -> unit = "ocaml_libvirt_domain_set_scheduler_parameters" + external define_xml : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_domain_define_xml" + external undefine : [>`W] t -> unit = "ocaml_libvirt_domain_undefine" + external create : [>`W] t -> unit = "ocaml_libvirt_domain_create" + external get_autostart : [>`R] t -> bool = "ocaml_libvirt_domain_get_autostart" + external set_autostart : [>`W] t -> bool -> unit = "ocaml_libvirt_domain_set_autostart" + external set_vcpus : [>`W] t -> int -> unit = "ocaml_libvirt_domain_set_vcpus" + external pin_vcpu : [>`W] t -> int -> string -> unit = "ocaml_libvirt_domain_pin_vcpu" + external get_vcpus : [>`R] t -> int -> int -> int * vcpu_info array * string = "ocaml_libvirt_domain_get_vcpus" + external get_cpu_stats : [>`R] t -> typed_param list array = "ocaml_libvirt_domain_get_cpu_stats" + external get_max_vcpus : [>`R] t -> int = "ocaml_libvirt_domain_get_max_vcpus" + external attach_device : [>`W] t -> xml -> unit = "ocaml_libvirt_domain_attach_device" + external detach_device : [>`W] t -> xml -> unit = "ocaml_libvirt_domain_detach_device" + external migrate : [>`W] t -> [>`W] Connect.t -> migrate_flag list -> ?dname:string -> ?uri:string -> ?bandwidth:int -> unit -> rw t = "ocaml_libvirt_domain_migrate_bytecode" "ocaml_libvirt_domain_migrate_native" + external block_stats : [>`R] t -> string -> block_stats = "ocaml_libvirt_domain_block_stats" + external interface_stats : [>`R] t -> string -> interface_stats = "ocaml_libvirt_domain_interface_stats" + external block_peek : [>`W] t -> string -> int64 -> int -> string -> int -> unit = "ocaml_libvirt_domain_block_peek_bytecode" "ocaml_libvirt_domain_block_peek_native" + external memory_peek : [>`W] t -> memory_flag list -> int64 -> int -> string -> int -> unit = "ocaml_libvirt_domain_memory_peek_bytecode" "ocaml_libvirt_domain_memory_peek_native" + + external get_all_domain_stats : [>`R] Connect.t -> stats_type list -> get_all_domain_stats_flag list -> domain_stats_record array = "ocaml_libvirt_domain_get_all_domain_stats" + + external const : [>`R] t -> ro t = "%identity" + + let get_domains conn flags = + (* Old/slow/inefficient method. *) + let get_active, get_inactive = + if List.mem ListAll flags then + (true, true) + else + (List.mem ListActive flags, List.mem ListInactive flags) in + let active_doms = + if get_active then ( + let n = Connect.num_of_domains conn in + let ids = Connect.list_domains conn n in + let ids = Array.to_list ids in + map_ignore_errors (lookup_by_id conn) ids + ) else [] in + + let inactive_doms = + if get_inactive then ( + let n = Connect.num_of_defined_domains conn in + let names = Connect.list_defined_domains conn n in + let names = Array.to_list names in + map_ignore_errors (lookup_by_name conn) names + ) else [] in + + active_doms @ inactive_doms + + let get_domains_and_infos conn flags = + (* Old/slow/inefficient method. *) + let get_active, get_inactive = + if List.mem ListAll flags then + (true, true) + else (List.mem ListActive flags, List.mem ListInactive flags) in + let active_doms = + if get_active then ( + let n = Connect.num_of_domains conn in + let ids = Connect.list_domains conn n in + let ids = Array.to_list ids in + map_ignore_errors (lookup_by_id conn) ids + ) else [] in + + let inactive_doms = + if get_inactive then ( + let n = Connect.num_of_defined_domains conn in + let names = Connect.list_defined_domains conn n in + let names = Array.to_list names in + map_ignore_errors (lookup_by_name conn) names + ) else [] in + + let doms = active_doms @ inactive_doms in + + map_ignore_errors (fun dom -> (dom, get_info dom)) doms +end + +module Event = +struct + + module Defined = struct + type t = [ + | `Added + | `Updated + | `Unknown of int + ] + + let to_string = function + | `Added -> "Added" + | `Updated -> "Updated" + | `Unknown x -> Printf.sprintf "Unknown Defined.detail: %d" x + + let make = function + | 0 -> `Added + | 1 -> `Updated + | x -> `Unknown x (* newer libvirt *) + end + + module Undefined = struct + type t = [ + | `Removed + | `Unknown of int + ] + + let to_string = function + | `Removed -> "UndefinedRemoved" + | `Unknown x -> Printf.sprintf "Unknown Undefined.detail: %d" x + + let make = function + | 0 -> `Removed + | x -> `Unknown x (* newer libvirt *) + end + + module Started = struct + type t = [ + | `Booted + | `Migrated + | `Restored + | `FromSnapshot + | `Wakeup + | `Unknown of int + ] + + let to_string = function + | `Booted -> "Booted" + | `Migrated -> "Migrated" + | `Restored -> "Restored" + | `FromSnapshot -> "FromSnapshot" + | `Wakeup -> "Wakeup" + | `Unknown x -> Printf.sprintf "Unknown Started.detail: %d" x + + let make = function + | 0 -> `Booted + | 1 -> `Migrated + | 2 -> `Restored + | 3 -> `FromSnapshot + | 4 -> `Wakeup + | x -> `Unknown x (* newer libvirt *) + end + + module Suspended = struct + type t = [ + | `Paused + | `Migrated + | `IOError + | `Watchdog + | `Restored + | `FromSnapshot + | `APIError + | `Unknown of int (* newer libvirt *) + ] + + let to_string = function + | `Paused -> "Paused" + | `Migrated -> "Migrated" + | `IOError -> "IOError" + | `Watchdog -> "Watchdog" + | `Restored -> "Restored" + | `FromSnapshot -> "FromSnapshot" + | `APIError -> "APIError" + | `Unknown x -> Printf.sprintf "Unknown Suspended.detail: %d" x + + let make = function + | 0 -> `Paused + | 1 -> `Migrated + | 2 -> `IOError + | 3 -> `Watchdog + | 4 -> `Restored + | 5 -> `FromSnapshot + | 6 -> `APIError + | x -> `Unknown x (* newer libvirt *) + end + + module Resumed = struct + type t = [ + | `Unpaused + | `Migrated + | `FromSnapshot + | `Unknown of int (* newer libvirt *) + ] + + let to_string = function + | `Unpaused -> "Unpaused" + | `Migrated -> "Migrated" + | `FromSnapshot -> "FromSnapshot" + | `Unknown x -> Printf.sprintf "Unknown Resumed.detail: %d" x + + let make = function + | 0 -> `Unpaused + | 1 -> `Migrated + | 2 -> `FromSnapshot + | x -> `Unknown x (* newer libvirt *) + end + + module Stopped = struct + type t = [ + | `Shutdown + | `Destroyed + | `Crashed + | `Migrated + | `Saved + | `Failed + | `FromSnapshot + | `Unknown of int + ] + let to_string = function + | `Shutdown -> "Shutdown" + | `Destroyed -> "Destroyed" + | `Crashed -> "Crashed" + | `Migrated -> "Migrated" + | `Saved -> "Saved" + | `Failed -> "Failed" + | `FromSnapshot -> "FromSnapshot" + | `Unknown x -> Printf.sprintf "Unknown Stopped.detail: %d" x + + let make = function + | 0 -> `Shutdown + | 1 -> `Destroyed + | 2 -> `Crashed + | 3 -> `Migrated + | 4 -> `Saved + | 5 -> `Failed + | 6 -> `FromSnapshot + | x -> `Unknown x (* newer libvirt *) + end + + module PM_suspended = struct + type t = [ + | `Memory + | `Disk + | `Unknown of int (* newer libvirt *) + ] + + let to_string = function + | `Memory -> "Memory" + | `Disk -> "Disk" + | `Unknown x -> Printf.sprintf "Unknown PM_suspended.detail: %d" x + + let make = function + | 0 -> `Memory + | 1 -> `Disk + | x -> `Unknown x (* newer libvirt *) + end + + let string_option x = match x with + | None -> "None" + | Some x' -> "Some " ^ x' + + module Lifecycle = struct + type t = [ + | `Defined of Defined.t + | `Undefined of Undefined.t + | `Started of Started.t + | `Suspended of Suspended.t + | `Resumed of Resumed.t + | `Stopped of Stopped.t + | `Shutdown (* no detail defined yet *) + | `PMSuspended of PM_suspended.t + | `Unknown of int (* newer libvirt *) + ] + + let to_string = function + | `Defined x -> "Defined " ^ (Defined.to_string x) + | `Undefined x -> "Undefined " ^ (Undefined.to_string x) + | `Started x -> "Started " ^ (Started.to_string x) + | `Suspended x -> "Suspended " ^ (Suspended.to_string x) + | `Resumed x -> "Resumed " ^ (Resumed.to_string x) + | `Stopped x -> "Stopped " ^ (Stopped.to_string x) + | `Shutdown -> "Shutdown" + | `PMSuspended x -> "PMSuspended " ^ (PM_suspended.to_string x) + | `Unknown x -> Printf.sprintf "Unknown Lifecycle event: %d" x + + let make (ty, detail) = match ty with + | 0 -> `Defined (Defined.make detail) + | 1 -> `Undefined (Undefined.make detail) + | 2 -> `Started (Started.make detail) + | 3 -> `Suspended (Suspended.make detail) + | 4 -> `Resumed (Resumed.make detail) + | 5 -> `Stopped (Stopped.make detail) + | 6 -> `Shutdown + | 7 -> `PMSuspended (PM_suspended.make detail) + | x -> `Unknown x + end + + module Reboot = struct + type t = unit + + let to_string _ = "()" + + let make () = () + end + + module Rtc_change = struct + type t = int64 + + let to_string = Int64.to_string + + let make x = x + end + + module Watchdog = struct + type t = [ + | `None + | `Pause + | `Reset + | `Poweroff + | `Shutdown + | `Debug + | `Unknown of int + ] + + let to_string = function + | `None -> "None" + | `Pause -> "Pause" + | `Reset -> "Reset" + | `Poweroff -> "Poweroff" + | `Shutdown -> "Shutdown" + | `Debug -> "Debug" + | `Unknown x -> Printf.sprintf "Unknown watchdog_action: %d" x + + let make = function + | 0 -> `None + | 1 -> `Pause + | 2 -> `Reset + | 3 -> `Poweroff + | 4 -> `Shutdown + | 5 -> `Debug + | x -> `Unknown x (* newer libvirt *) + end + + module Io_error = struct + type action = [ + | `None + | `Pause + | `Report + | `Unknown of int (* newer libvirt *) + ] + + let string_of_action = function + | `None -> "None" + | `Pause -> "Pause" + | `Report -> "Report" + | `Unknown x -> Printf.sprintf "Unknown Io_error.action: %d" x + + let action_of_int = function + | 0 -> `None + | 1 -> `Pause + | 2 -> `Report + | x -> `Unknown x + + type t = { + src_path: string option; + dev_alias: string option; + action: action; + reason: string option; + } + + let to_string t = Printf.sprintf + "{ Io_error.src_path = %s; dev_alias = %s; action = %s; reason = %s }" + (string_option t.src_path) + (string_option t.dev_alias) + (string_of_action t.action) + (string_option t.reason) + + let make (src_path, dev_alias, action, reason) = { + src_path = src_path; + dev_alias = dev_alias; + action = action_of_int action; + reason = reason; + } + + let make_noreason (src_path, dev_alias, action) = + make (src_path, dev_alias, action, None) + end + + module Graphics_address = struct + type family = [ + | `Ipv4 + | `Ipv6 + | `Unix + | `Unknown of int (* newer libvirt *) + ] + + let string_of_family = function + | `Ipv4 -> "IPv4" + | `Ipv6 -> "IPv6" + | `Unix -> "UNIX" + | `Unknown x -> Printf.sprintf "Unknown Graphics_address.family: %d" x + + let family_of_int = function + (* no zero *) + | 1 -> `Ipv4 + | 2 -> `Ipv6 + | 3 -> `Unix + | x -> `Unknown x + + type t = { + family: family; (** Address family *) + node: string option; (** Address of node (eg IP address, or UNIX path *) + service: string option; (** Service name/number (eg TCP port, or NULL) *) + } + + let to_string t = Printf.sprintf + "{ family = %s; node = %s; service = %s }" + (string_of_family t.family) + (string_option t.node) + (string_option t.service) + + let make (family, node, service) = { + family = family_of_int family; + node = node; + service = service; + } + end + + module Graphics_subject = struct + type identity = { + ty: string option; + name: string option; + } + + let string_of_identity t = Printf.sprintf + "{ ty = %s; name = %s }" + (string_option t.ty) + (string_option t.name) + + type t = identity list + + let to_string ts = + "[ " ^ (String.concat "; " (List.map string_of_identity ts)) ^ " ]" + + let make xs = + List.map (fun (ty, name) -> { ty = ty; name = name }) + (Array.to_list xs) + end + + module Graphics = struct + type phase = [ + | `Connect + | `Initialize + | `Disconnect + | `Unknown of int (** newer libvirt *) + ] + + let string_of_phase = function + | `Connect -> "Connect" + | `Initialize -> "Initialize" + | `Disconnect -> "Disconnect" + | `Unknown x -> Printf.sprintf "Unknown Graphics.phase: %d" x + + let phase_of_int = function + | 0 -> `Connect + | 1 -> `Initialize + | 2 -> `Disconnect + | x -> `Unknown x + + type t = { + phase: phase; (** the phase of the connection *) + local: Graphics_address.t; (** the local server address *) + remote: Graphics_address.t; (** the remote client address *) + auth_scheme: string option; (** the authentication scheme activated *) + subject: Graphics_subject.t; (** the authenticated subject (user) *) + } + + let to_string t = + let phase = Printf.sprintf "phase = %s" + (string_of_phase t.phase) in + let local = Printf.sprintf "local = %s" + (Graphics_address.to_string t.local) in + let remote = Printf.sprintf "remote = %s" + (Graphics_address.to_string t.remote) in + let auth_scheme = Printf.sprintf "auth_scheme = %s" + (string_option t.auth_scheme) in + let subject = Printf.sprintf "subject = %s" + (Graphics_subject.to_string t.subject) in + "{ " ^ (String.concat "; " [ phase; local; remote; auth_scheme; subject ]) ^ " }" + + let make (phase, local, remote, auth_scheme, subject) = { + phase = phase_of_int phase; + local = Graphics_address.make local; + remote = Graphics_address.make remote; + auth_scheme = auth_scheme; + subject = Graphics_subject.make subject; + } + end + + module Control_error = struct + type t = unit + + let to_string () = "()" + + let make () = () + end + + module Block_job = struct + type ty = [ + | `KnownUnknown (* explicitly named UNKNOWN in the spec *) + | `Pull + | `Copy + | `Commit + | `Unknown of int (* newer libvirt *) + ] + + let string_of_ty = function + | `KnownUnknown -> "KnownUnknown" + | `Pull -> "Pull" + | `Copy -> "Copy" + | `Commit -> "Commit" + | `Unknown x -> Printf.sprintf "Unknown Block_job.ty: %d" x + + let ty_of_int = function + | 0 -> `KnownUnknown + | 1 -> `Pull + | 2 -> `Copy + | 3 -> `Commit + | x -> `Unknown x (* newer libvirt *) + + type status = [ + | `Completed + | `Failed + | `Cancelled + | `Ready + | `Unknown of int + ] + + let string_of_status = function + | `Completed -> "Completed" + | `Failed -> "Failed" + | `Cancelled -> "Cancelled" + | `Ready -> "Ready" + | `Unknown x -> Printf.sprintf "Unknown Block_job.status: %d" x + + let status_of_int = function + | 0 -> `Completed + | 1 -> `Failed + | 2 -> `Cancelled + | 3 -> `Ready + | x -> `Unknown x + + type t = { + disk: string option; + ty: ty; + status: status; + } + + let to_string t = Printf.sprintf "{ disk = %s; ty = %s; status = %s }" + (string_option t.disk) + (string_of_ty t.ty) + (string_of_status t.status) + + let make (disk, ty, status) = { + disk = disk; + ty = ty_of_int ty; + status = status_of_int ty; + } + end + + module Disk_change = struct + type reason = [ + | `MissingOnStart + | `Unknown of int + ] + + let string_of_reason = function + | `MissingOnStart -> "MissingOnStart" + | `Unknown x -> Printf.sprintf "Unknown Disk_change.reason: %d" x + + let reason_of_int = function + | 0 -> `MissingOnStart + | x -> `Unknown x + + type t = { + old_src_path: string option; + new_src_path: string option; + dev_alias: string option; + reason: reason; + } + + let to_string t = + let o = Printf.sprintf "old_src_path = %s" (string_option t.old_src_path) in + let n = Printf.sprintf "new_src_path = %s" (string_option t.new_src_path) in + let d = Printf.sprintf "dev_alias = %s" (string_option t.dev_alias) in + let r = string_of_reason t.reason in + "{ " ^ (String.concat "; " [ o; n; d; r ]) ^ " }" + + let make (o, n, d, r) = { + old_src_path = o; + new_src_path = n; + dev_alias = d; + reason = reason_of_int r; + } + end + + module Tray_change = struct + type reason = [ + | `Open + | `Close + | `Unknown of int + ] + + let string_of_reason = function + | `Open -> "Open" + | `Close -> "Close" + | `Unknown x -> Printf.sprintf "Unknown Tray_change.reason: %d" x + + let reason_of_int = function + | 0 -> `Open + | 1 -> `Close + | x -> `Unknown x + + type t = { + dev_alias: string option; + reason: reason; + } + + let to_string t = Printf.sprintf + "{ dev_alias = %s; reason = %s }" + (string_option t.dev_alias) + (string_of_reason t.reason) + + let make (dev_alias, reason) = { + dev_alias = dev_alias; + reason = reason_of_int reason; + } + end + + module PM_wakeup = struct + type reason = [ + | `Unknown of int + ] + + type t = reason + + let to_string = function + | `Unknown x -> Printf.sprintf "Unknown PM_wakeup.reason: %d" x + + let make x = `Unknown x + end + + module PM_suspend = struct + type reason = [ + | `Unknown of int + ] + + type t = reason + + let to_string = function + | `Unknown x -> Printf.sprintf "Unknown PM_suspend.reason: %d" x + + let make x = `Unknown x + end + + module Balloon_change = struct + type t = int64 + + let to_string = Int64.to_string + let make x = x + end + + module PM_suspend_disk = struct + type reason = [ + | `Unknown of int + ] + + type t = reason + + let to_string = function + | `Unknown x -> Printf.sprintf "Unknown PM_suspend_disk.reason: %d" x + + let make x = `Unknown x + end + + type callback = + | Lifecycle of ([`R] Domain.t -> Lifecycle.t -> unit) + | Reboot of ([`R] Domain.t -> Reboot.t -> unit) + | RtcChange of ([`R] Domain.t -> Rtc_change.t -> unit) + | Watchdog of ([`R] Domain.t -> Watchdog.t -> unit) + | IOError of ([`R] Domain.t -> Io_error.t -> unit) + | Graphics of ([`R] Domain.t -> Graphics.t -> unit) + | IOErrorReason of ([`R] Domain.t -> Io_error.t -> unit) + | ControlError of ([`R] Domain.t -> Control_error.t -> unit) + | BlockJob of ([`R] Domain.t -> Block_job.t -> unit) + | DiskChange of ([`R] Domain.t -> Disk_change.t -> unit) + | TrayChange of ([`R] Domain.t -> Tray_change.t -> unit) + | PMWakeUp of ([`R] Domain.t -> PM_wakeup.t -> unit) + | PMSuspend of ([`R] Domain.t -> PM_suspend.t -> unit) + | BalloonChange of ([`R] Domain.t -> Balloon_change.t -> unit) + | PMSuspendDisk of ([`R] Domain.t -> PM_suspend_disk.t -> unit) + + type callback_id = int64 + + let fresh_callback_id = + let next = ref 0L in + fun () -> + let result = !next in + next := Int64.succ !next; + result + + let make_table value_name = + let table = Hashtbl.create 16 in + let callback callback_id generic x = + if Hashtbl.mem table callback_id + then Hashtbl.find table callback_id generic x in + let _ = Callback.register value_name callback in + table + + let u_table = make_table "Libvirt.u_callback" + let i_table = make_table "Libvirt.i_callback" + let i64_table = make_table "Libvirt.i64_callback" + let i_i_table = make_table "Libvirt.i_i_callback" + let s_i_table = make_table "Libvirt.s_i_callback" + let s_i_i_table = make_table "Libvirt.s_i_i_callback" + let s_s_i_table = make_table "Libvirt.s_s_i_callback" + let s_s_i_s_table = make_table "Libvirt.s_s_i_s_callback" + let s_s_s_i_table = make_table "Libvirt.s_s_s_i_callback" + let i_ga_ga_s_gs_table = make_table "Libvirt.i_ga_ga_s_gs_callback" + + external register_default_impl : unit -> unit = "ocaml_libvirt_event_register_default_impl" + + external run_default_impl : unit -> unit = "ocaml_libvirt_event_run_default_impl" + + external register_any' : 'a Connect.t -> 'a Domain.t option -> callback -> callback_id -> int = "ocaml_libvirt_connect_domain_event_register_any" + + external deregister_any' : 'a Connect.t -> int -> unit = "ocaml_libvirt_connect_domain_event_deregister_any" + + let our_id_to_libvirt_id = Hashtbl.create 16 + + let register_any conn ?dom callback = + let id = fresh_callback_id () in + begin match callback with + | Lifecycle f -> + Hashtbl.add i_i_table id (fun dom x -> + f dom (Lifecycle.make x) + ) + | Reboot f -> + Hashtbl.add u_table id (fun dom x -> + f dom (Reboot.make x) + ) + | RtcChange f -> + Hashtbl.add i64_table id (fun dom x -> + f dom (Rtc_change.make x) + ) + | Watchdog f -> + Hashtbl.add i_table id (fun dom x -> + f dom (Watchdog.make x) + ) + | IOError f -> + Hashtbl.add s_s_i_table id (fun dom x -> + f dom (Io_error.make_noreason x) + ) + | Graphics f -> + Hashtbl.add i_ga_ga_s_gs_table id (fun dom x -> + f dom (Graphics.make x) + ) + | IOErrorReason f -> + Hashtbl.add s_s_i_s_table id (fun dom x -> + f dom (Io_error.make x) + ) + | ControlError f -> + Hashtbl.add u_table id (fun dom x -> + f dom (Control_error.make x) + ) + | BlockJob f -> + Hashtbl.add s_i_i_table id (fun dom x -> + f dom (Block_job.make x) + ) + | DiskChange f -> + Hashtbl.add s_s_s_i_table id (fun dom x -> + f dom (Disk_change.make x) + ) + | TrayChange f -> + Hashtbl.add s_i_table id (fun dom x -> + f dom (Tray_change.make x) + ) + | PMWakeUp f -> + Hashtbl.add i_table id (fun dom x -> + f dom (PM_wakeup.make x) + ) + | PMSuspend f -> + Hashtbl.add i_table id (fun dom x -> + f dom (PM_suspend.make x) + ) + | BalloonChange f -> + Hashtbl.add i64_table id (fun dom x -> + f dom (Balloon_change.make x) + ) + | PMSuspendDisk f -> + Hashtbl.add i_table id (fun dom x -> + f dom (PM_suspend_disk.make x) + ) + end; + let libvirt_id = register_any' conn dom callback id in + Hashtbl.replace our_id_to_libvirt_id id libvirt_id; + id + + let deregister_any conn id = + if Hashtbl.mem our_id_to_libvirt_id id then begin + let libvirt_id = Hashtbl.find our_id_to_libvirt_id id in + deregister_any' conn libvirt_id + end; + Hashtbl.remove our_id_to_libvirt_id id; + Hashtbl.remove u_table id; + Hashtbl.remove i_table id; + Hashtbl.remove i64_table id; + Hashtbl.remove i_i_table id; + Hashtbl.remove s_i_table id; + Hashtbl.remove s_i_i_table id; + Hashtbl.remove s_s_i_table id; + Hashtbl.remove s_s_i_s_table id; + Hashtbl.remove s_s_s_i_table id; + Hashtbl.remove i_ga_ga_s_gs_table id + + let timeout_table = Hashtbl.create 16 + let _ = + let callback x = + if Hashtbl.mem timeout_table x + then Hashtbl.find timeout_table x () in + Callback.register "Libvirt.timeout_callback" callback + + type timer_id = int64 + + external add_timeout' : 'a Connect.t -> int -> int64 -> int = "ocaml_libvirt_event_add_timeout" + + external remove_timeout' : 'a Connect.t -> int -> unit = "ocaml_libvirt_event_remove_timeout" + + let our_id_to_timer_id = Hashtbl.create 16 + let add_timeout conn ms fn = + let id = fresh_callback_id () in + Hashtbl.add timeout_table id fn; + let timer_id = add_timeout' conn ms id in + Hashtbl.add our_id_to_timer_id id timer_id; + id + + let remove_timeout conn id = + if Hashtbl.mem our_id_to_timer_id id then begin + let timer_id = Hashtbl.find our_id_to_timer_id id in + remove_timeout' conn timer_id + end; + Hashtbl.remove our_id_to_timer_id id; + Hashtbl.remove timeout_table id +end + +module Network = +struct + type 'rw t + + external lookup_by_name : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_network_lookup_by_name" + external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t = "ocaml_libvirt_network_lookup_by_uuid" + external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_network_lookup_by_uuid_string" + external create_xml : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_network_create_xml" + external define_xml : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_network_define_xml" + external undefine : [>`W] t -> unit = "ocaml_libvirt_network_undefine" + external create : [>`W] t -> unit = "ocaml_libvirt_network_create" + external destroy : [>`W] t -> unit = "ocaml_libvirt_network_destroy" + external free : [>`R] t -> unit = "ocaml_libvirt_network_free" + external get_name : [>`R] t -> string = "ocaml_libvirt_network_get_name" + external get_uuid : [>`R] t -> uuid = "ocaml_libvirt_network_get_uuid" + external get_uuid_string : [>`R] t -> string = "ocaml_libvirt_network_get_uuid_string" + external get_xml_desc : [>`R] t -> xml = "ocaml_libvirt_network_get_xml_desc" + external get_bridge_name : [>`R] t -> string = "ocaml_libvirt_network_get_bridge_name" + external get_autostart : [>`R] t -> bool = "ocaml_libvirt_network_get_autostart" + external set_autostart : [>`W] t -> bool -> unit = "ocaml_libvirt_network_set_autostart" + + external const : [>`R] t -> ro t = "%identity" +end + +module Pool = +struct + type 'rw t + type pool_state = Inactive | Building | Running | Degraded | Inaccessible + type pool_build_flags = New | Repair | Resize + type pool_delete_flags = Normal | Zeroed + type pool_info = { + state : pool_state; + capacity : int64; + allocation : int64; + available : int64; + } + + external lookup_by_name : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_storage_pool_lookup_by_name" + external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t = "ocaml_libvirt_storage_pool_lookup_by_uuid" + external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_storage_pool_lookup_by_uuid_string" + external create_xml : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_storage_pool_create_xml" + external define_xml : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_storage_pool_define_xml" + external build : [>`W] t -> pool_build_flags -> unit = "ocaml_libvirt_storage_pool_build" + external undefine : [>`W] t -> unit = "ocaml_libvirt_storage_pool_undefine" + external create : [>`W] t -> unit = "ocaml_libvirt_storage_pool_create" + external destroy : [>`W] t -> unit = "ocaml_libvirt_storage_pool_destroy" + external delete : [>`W] t -> unit = "ocaml_libvirt_storage_pool_delete" + external free : [>`R] t -> unit = "ocaml_libvirt_storage_pool_free" + external refresh : [`R] t -> unit = "ocaml_libvirt_storage_pool_refresh" + external get_name : [`R] t -> string = "ocaml_libvirt_storage_pool_get_name" + external get_uuid : [`R] t -> uuid = "ocaml_libvirt_storage_pool_get_uuid" + external get_uuid_string : [`R] t -> string = "ocaml_libvirt_storage_pool_get_uuid_string" + external get_info : [`R] t -> pool_info = "ocaml_libvirt_storage_pool_get_info" + external get_xml_desc : [`R] t -> xml = "ocaml_libvirt_storage_pool_get_xml_desc" + external get_autostart : [`R] t -> bool = "ocaml_libvirt_storage_pool_get_autostart" + external set_autostart : [>`W] t -> bool -> unit = "ocaml_libvirt_storage_pool_set_autostart" + external num_of_volumes : [`R] t -> int = "ocaml_libvirt_storage_pool_num_of_volumes" + external list_volumes : [`R] t -> int -> string array = "ocaml_libvirt_storage_pool_list_volumes" + external const : [>`R] t -> ro t = "%identity" +end + +module Volume = +struct + type 'rw t + type vol_type = File | Block | Dir | Network | NetDir | Ploop + type vol_delete_flags = Normal | Zeroed + type vol_info = { + typ : vol_type; + capacity : int64; + allocation : int64; + } + + external lookup_by_name : 'a Pool.t -> string -> 'a t = "ocaml_libvirt_storage_vol_lookup_by_name" + external lookup_by_key : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_storage_vol_lookup_by_key" + external lookup_by_path : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_storage_vol_lookup_by_path" + external pool_of_volume : 'a t -> 'a Pool.t = "ocaml_libvirt_storage_pool_lookup_by_volume" + external get_name : [`R] t -> string = "ocaml_libvirt_storage_vol_get_name" + external get_key : [`R] t -> string = "ocaml_libvirt_storage_vol_get_key" + external get_path : [`R] t -> string = "ocaml_libvirt_storage_vol_get_path" + external get_info : [`R] t -> vol_info = "ocaml_libvirt_storage_vol_get_info" + external get_xml_desc : [`R] t -> xml = "ocaml_libvirt_storage_vol_get_xml_desc" + external create_xml : [>`W] Pool.t -> xml -> unit = "ocaml_libvirt_storage_vol_create_xml" + external delete : [>`W] t -> vol_delete_flags -> unit = "ocaml_libvirt_storage_vol_delete" + external free : [>`R] t -> unit = "ocaml_libvirt_storage_vol_free" + external const : [>`R] t -> ro t = "%identity" +end + +module Secret = +struct + type 'rw t + type secret_usage_type = + | NoType + | Volume + | Ceph + | ISCSI + | TLS + + external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t = "ocaml_libvirt_secret_lookup_by_uuid" + external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_secret_lookup_by_uuid_string" + external lookup_by_usage : 'a Connect.t -> secret_usage_type -> string -> 'a t = "ocaml_libvirt_secret_lookup_by_usage" + external define_xml : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_secret_define_xml" + external get_uuid : [>`R] t -> uuid = "ocaml_libvirt_secret_get_uuid" + external get_uuid_string : [>`R] t -> string = "ocaml_libvirt_secret_get_uuid_string" + external get_usage_type : [>`R] t -> secret_usage_type = "ocaml_libvirt_secret_get_usage_type" + external get_usage_id : [>`R] t -> string = "ocaml_libvirt_secret_get_usage_id" + external get_xml_desc : [>`R] t -> xml = "ocaml_libvirt_secret_get_xml_desc" + external set_value : [>`W] t -> bytes -> unit = "ocaml_libvirt_secret_set_value" + external get_value : [>`R] t -> bytes = "ocaml_libvirt_secret_get_value" + external undefine : [>`W] t -> unit = "ocaml_libvirt_secret_undefine" + external free : [>`R] t -> unit = "ocaml_libvirt_secret_free" + external const : [>`R] t -> ro t = "%identity" +end + +(* Initialization. *) +external c_init : unit -> unit = "ocaml_libvirt_init" +let () = + Callback.register_exception + "ocaml_libvirt_virterror" (Virterror (Virterror.no_error ())); + Callback.register_exception + "ocaml_libvirt_not_supported" (Not_supported ""); + c_init (); + Printexc.register_printer ( + function + | Virterror e -> Some (Virterror.to_string e) + | _ -> None + ) diff --git a/common/mllibvirt/libvirt.mli b/common/mllibvirt/libvirt.mli new file mode 100644 index 000000000..628f79715 --- /dev/null +++ b/common/mllibvirt/libvirt.mli @@ -0,0 +1,1626 @@ +(** OCaml bindings for libvirt. *) +(* (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc. + https://libvirt.org/ + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version, + with the OCaml linking exception described in ../COPYING.LIB. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +*) + +(** + {2 Introduction and examples} + + This is a set of bindings for writing OCaml programs to + manage virtual machines through {{:https://libvirt.org/}libvirt}. + + {3 Using libvirt interactively} + + Using the interactive toplevel: + +{v +$ ocaml -I +libvirt + Objective Caml version 3.10.0 + +# #load "unix.cma";; +# #load "mllibvirt.cma";; +# let name = "test:///default";; +val name : string = "test:///default" +# let conn = Libvirt.Connect.connect_readonly ~name () ;; +val conn : Libvirt.ro Libvirt.Connect.t = <abstr> +# Libvirt.Connect.get_node_info conn;; + : Libvirt.Connect.node_info = +{Libvirt.Connect.model = "i686"; Libvirt.Connect.memory = 3145728L; + Libvirt.Connect.cpus = 16; Libvirt.Connect.mhz = 1400; + Libvirt.Connect.nodes = 2; Libvirt.Connect.sockets = 2; + Libvirt.Connect.cores = 2; Libvirt.Connect.threads = 2} +v} + + {3 Compiling libvirt programs} + + This command compiles a program to native code: + +{v +ocamlopt -I +libvirt mllibvirt.cmxa list_domains.ml -o list_domains +v} + + {3 Example: Connect to the hypervisor} + + The main modules are {!Libvirt.Connect}, {!Libvirt.Domain} and + {!Libvirt.Network} corresponding respectively to the + {{:https://libvirt.org/html/libvirt-libvirt-host.html}virConnect*}, + {{:https://libvirt.org/html/libvirt-libvirt-domain.html}virDomain*}, and + {{:https://libvirt.org/html/libvirt-libvirt-network.html}virNetwork*} + functions from libvirt. + For brevity I usually rename these modules like this: + +{[ +module C = Libvirt.Connect +module D = Libvirt.Domain +module N = Libvirt.Network +]} + + To get a connection handle, assuming a Xen hypervisor: + +{[ +let name = "xen:///" +let conn = C.connect_readonly ~name () +]} + + {3 Example: List running domains} + +{[ +open Printf + +let domains = D.get_domains conn [D.ListActive] in +List.iter ( + fun dom -> + printf "%8d %s\n%!" (D.get_id dom) (D.get_name dom) +) domains; +]} + + {3 Example: List inactive domains} + +{[ +let domains = D.get_domains conn [D.ListInactive] in +List.iter ( + fun dom -> + printf "inactive %s\n%!" (D.get_name dom) +) domains; +]} + + {3 Example: Print node info} + +{[ +let node_info = C.get_node_info conn in +printf "model = %s\n" node_info.C.model; +printf "memory = %Ld K\n" node_info.C.memory; +printf "cpus = %d\n" node_info.C.cpus; +printf "mhz = %d\n" node_info.C.mhz; +printf "nodes = %d\n" node_info.C.nodes; +printf "sockets = %d\n" node_info.C.sockets; +printf "cores = %d\n" node_info.C.cores; +printf "threads = %d\n%!" node_info.C.threads; + +let hostname = C.get_hostname conn in +printf "hostname = %s\n%!" hostname; + +let uri = C.get_uri conn in +printf "uri = %s\n%!" uri +]} + +*) + + +(** {2 Programming issues} + + {3 General safety issues} + + Memory allocation / automatic garbage collection of all libvirt + objects should be completely safe. If you find any safety issues + or if your pure OCaml program ever segfaults, please contact the author. + + You can force a libvirt object to be freed early by calling + the {!Libvirt.Connect.close} function on the object. This shouldn't + affect the safety of garbage collection and should only be used when + you want to explicitly free memory. Note that explicitly + closing a connection object does nothing if there are still + unclosed domain or network objects referencing it. + + Note that even though you hold open (eg) a domain object, that + doesn't mean that the domain (virtual machine) actually exists. + The domain could have been shut down or deleted by another user. + Thus domain objects can raise odd exceptions at any time. + This is just the nature of virtualisation. + + {3 Backwards and forwards compatibility} + + OCaml-libvirt requires libvirt version 1.0.2 or later. Future + releases of OCaml-libvirt will use newer features of libvirt + and therefore will require later versions of libvirt. It is always + possible to dynamically link your application against a newer + libvirt than OCaml-libvirt was originally compiled against. + + {3 Get list of domains and domain infos} + + This is a very common operation, and libvirt supports various + different methods to do it. We have hidden the complexity in a + flexible {!Libvirt.Domain.get_domains} and + {!Libvirt.Domain.get_domains_and_infos} calls which is easy to use and + automatically chooses the most efficient method depending on the + version of libvirt in use. + + {3 Threads} + + You can issue multiple concurrent libvirt requests in + different threads. However you must follow this rule: + Each thread must have its own separate libvirt connection, {i or} + you must implement your own mutex scheme to ensure that no + two threads can ever make concurrent calls using the same + libvirt connection. + + (Note that multithreaded code is not well tested. If you find + bugs please report them.) + + {3 Initialisation} + + Libvirt requires all callers to call virInitialize before + using the library. This is done automatically for you by + these bindings when the program starts up, and we believe + that the way this is done is safe. + + {2 Reference} +*) + +type uuid = string + (** This is a "raw" UUID, ie. a packed string of bytes. *) + +type xml = string + (** Type of XML (an uninterpreted string of bytes). Use PXP, expat, + xml-light, etc. if you want to do anything useful with the XML. + *) + +type filename = string + (** A filename. *) + +val get_version : ?driver:string -> unit -> int * int + (** [get_version ()] returns the library version in the first part + of the tuple, and [0] in the second part. + + [get_version ~driver ()] returns the library version in the first + part of the tuple, and the version of the driver called [driver] + in the second part. + + The version numbers are encoded as + [major * 1_000_000 + minor * 1000 + release]. + *) + +val uuid_length : int + (** Length of packed UUIDs. *) + +val uuid_string_length : int + (** Length of UUID strings. *) + +type rw = [`R|`W] +type ro = [`R] + (** These + {{:https://caml.inria.fr/pub/ml-archives/caml-list/2004/07/80683af867cce6bf8fff273973f70c95.en.html}phantom types} + are used to ensure the type-safety of read-only + versus read-write connections. + + All connection/domain/etc. objects are marked with + a phantom read-write or read-only type, and trying to + pass a read-only object into a function which could + mutate the object will cause a compile time error. + + Each module provides a function like {!Libvirt.Connect.const} + to demote a read-write object into a read-only object. The + opposite operation is, of course, not allowed. + + If you want to handle both read-write and read-only + connections at runtime, use a variant similar to this: +{[ +type conn_t = + | No_connection + | Read_only of Libvirt.ro Libvirt.Connect.t + | Read_write of Libvirt.rw Libvirt.Connect.t +]} + *) + +(** {3 Forward definitions} + + These definitions are placed here to avoid the need to + use recursive module dependencies. +*) + +(** {3 Connections} *) + +module Connect : +sig + type 'rw t + (** Connection. Read-only connections have type [ro Connect.t] and + read-write connections have type [rw Connect.t]. + *) + + type node_info = { + model : string; (** CPU model *) + memory : int64; (** memory size in kilobytes *) + cpus : int; (** number of active CPUs *) + mhz : int; (** expected CPU frequency *) + nodes : int; (** number of NUMA nodes (1 = UMA) *) + sockets : int; (** number of CPU sockets per node *) + cores : int; (** number of cores per socket *) + threads : int; (** number of threads per core *) + } + + type credential_type = + | CredentialUsername (** Identity to act as *) + | CredentialAuthname (** Identify to authorize as *) + | CredentialLanguage (** RFC 1766 languages, comma separated *) + | CredentialCnonce (** client supplies a nonce *) + | CredentialPassphrase (** Passphrase secret *) + | CredentialEchoprompt (** Challenge response *) + | CredentialNoechoprompt (** Challenge response *) + | CredentialRealm (** Authentication realm *) + | CredentialExternal (** Externally managed credential *) + + type credential = { + typ : credential_type; (** The type of credential *) + prompt : string; (** Prompt to show to user *) + challenge : string option; (** Additional challenge to show *) + defresult : string option; (** Optional default result *) + } + + type auth = { + credtype : credential_type list; (** List of supported credential_type values *) + cb : (credential list -> string option list); + (** Callback used to collect credentials. + + The input is a list of all the requested credentials. + + The function returns a list of all the results from the + requested credentials, so the number of results {e must} match + the number of input credentials. Each result is optional, + and in case it is [None] it means there was no result. + *) + } + + val connect : ?name:string -> unit -> rw t + (** [connect ~name ()] connects to the hypervisor with URI [name]. + + [connect ()] connects to the default hypervisor. + *) + val connect_readonly : ?name:string -> unit -> ro t + (** [connect_readonly ~name ()] connects in read-only mode + to the hypervisor with URI [name]. + + [connect_readonly ()] connects in read-only mode to the + default hypervisor. + *) + + val connect_auth : ?name:string -> auth -> rw t + (** [connect_auth ~name auth] connects to the hypervisor with URI + [name], using [auth] as authentication handler. + + [connect_auth auth] connects to the default hypervisor, using + [auth] as authentication handler. + *) + val connect_auth_readonly : ?name:string -> auth -> ro t + (** [connect_auth_readonly ~name auth] connects in read-only mode + to the hypervisor with URI [name], using [auth] as authentication + handler. + + [connect_auth_readonly auth] connects in read-only mode to the + default hypervisor, using [auth] as authentication handler. + *) + + val close : [>`R] t -> unit + (** [close conn] closes and frees the connection object in memory. + + The connection is automatically closed if it is garbage + collected. This function just forces it to be closed + and freed right away. + *) + + val get_type : [>`R] t -> string + (** Returns the name of the driver (hypervisor). *) + + val get_version : [>`R] t -> int + (** Returns the driver version + [major * 1_000_000 + minor * 1000 + release] + *) + val get_hostname : [>`R] t -> string + (** Returns the hostname of the physical server. *) + val get_uri : [>`R] t -> string + (** Returns the canonical connection URI. *) + val get_max_vcpus : [>`R] t -> ?type_:string -> unit -> int + (** Returns the maximum number of virtual CPUs + supported by a guest VM of a particular type. *) + val list_domains : [>`R] t -> int -> int array + (** [list_domains conn max] returns the running domain IDs, + up to a maximum of [max] entries. + + Call {!num_of_domains} first to get a value for [max]. + + See also: + {!Libvirt.Domain.get_domains}, + {!Libvirt.Domain.get_domains_and_infos}. + *) + val num_of_domains : [>`R] t -> int + (** Returns the number of running domains. *) + val get_capabilities : [>`R] t -> xml + (** Returns the hypervisor capabilities (as XML). *) + val num_of_defined_domains : [>`R] t -> int + (** Returns the number of inactive (shutdown) domains. *) + val list_defined_domains : [>`R] t -> int -> string array + (** [list_defined_domains conn max] + returns the names of the inactive domains, up to + a maximum of [max] entries. + + Call {!num_of_defined_domains} first to get a value for [max]. + + See also: + {!Libvirt.Domain.get_domains}, + {!Libvirt.Domain.get_domains_and_infos}. + *) + val num_of_networks : [>`R] t -> int + (** Returns the number of networks. *) + val list_networks : [>`R] t -> int -> string array + (** [list_networks conn max] + returns the names of the networks, up to a maximum + of [max] entries. + Call {!num_of_networks} first to get a value for [max]. + *) + val num_of_defined_networks : [>`R] t -> int + (** Returns the number of inactive networks. *) + val list_defined_networks : [>`R] t -> int -> string array + (** [list_defined_networks conn max] + returns the names of the inactive networks, up to a maximum + of [max] entries. + Call {!num_of_defined_networks} first to get a value for [max]. + *) + + val num_of_pools : [>`R] t -> int + (** Returns the number of storage pools. *) + val list_pools : [>`R] t -> int -> string array + (** Return list of storage pools. *) + val num_of_defined_pools : [>`R] t -> int + (** Returns the number of storage pools. *) + val list_defined_pools : [>`R] t -> int -> string array + (** Return list of storage pools. *) + + (* The name of this function is inconsistent, but the inconsistency + * is really in libvirt itself. + *) + val num_of_secrets : [>`R] t -> int + (** Returns the number of secrets. *) + val list_secrets : [>`R] t -> int -> string array + (** Returns the list of secrets. *) + val get_node_info : [>`R] t -> node_info + (** Return information about the physical server. *) + + val node_get_free_memory : [> `R] t -> int64 + (** + [node_get_free_memory conn] + returns the amount of free memory (not allocated to any guest) + in the machine. + *) + + val node_get_cells_free_memory : [> `R] t -> int -> int -> int64 array + (** + [node_get_cells_free_memory conn start max] + returns the amount of free memory on each NUMA cell in kilobytes. + [start] is the first cell for which we return free memory. + [max] is the maximum number of cells for which we return free memory. + Returns an array of up to [max] entries in length. + *) + + val maxcpus_of_node_info : node_info -> int + (** Calculate the total number of CPUs supported (but not necessarily + active) in the host. + *) + + val cpumaplen : int -> int + (** Calculate the length (in bytes) required to store the complete + CPU map between a single virtual and all physical CPUs of a domain. + *) + + val use_cpu : bytes -> int -> unit + (** [use_cpu cpumap cpu] marks [cpu] as usable in [cpumap]. *) + val unuse_cpu : bytes -> int -> unit + (** [unuse_cpu cpumap cpu] marks [cpu] as not usable in [cpumap]. *) + val cpu_usable : bytes -> int -> int -> int -> bool + (** [cpu_usable cpumaps maplen vcpu cpu] checks returns true iff the + [cpu] is usable by [vcpu]. *) + + val set_keep_alive : [>`R] t -> int -> int -> unit + (** [set_keep_alive conn interval count] starts sending keepalive + messages after [interval] seconds of inactivity and consider the + connection to be broken when no response is received after [count] + keepalive messages. + Note: the client has to implement and run an event loop to + be able to use keep-alive messages. *) + + val get_auth_default : unit -> auth + (** [get_auth_default ()] returns the default authentication handler + of libvirt. + *) + + external const : [>`R] t -> ro t = "%identity" + (** [const conn] turns a read/write connection into a read-only + connection. Note that the opposite operation is impossible. + *) +end + (** Module dealing with connections. [Connect.t] is the + connection object. *) + +(** {3 Domains} *) + +module Domain : +sig + type 'rw t + (** Domain handle. Read-only handles have type [ro Domain.t] and + read-write handles have type [rw Domain.t]. + *) + + type state = + | InfoNoState | InfoRunning | InfoBlocked | InfoPaused + | InfoShutdown | InfoShutoff | InfoCrashed | InfoPMSuspended + + type info = { + state : state; (** running state *) + max_mem : int64; (** maximum memory in kilobytes *) + memory : int64; (** memory used in kilobytes *) + nr_virt_cpu : int; (** number of virtual CPUs *) + cpu_time : int64; (** CPU time used in nanoseconds *) + } + + type vcpu_state = VcpuOffline | VcpuRunning | VcpuBlocked + + type vcpu_info = { + number : int; (** virtual CPU number *) + vcpu_state : vcpu_state; (** state *) + vcpu_time : int64; (** CPU time used in nanoseconds *) + cpu : int; (** real CPU number, -1 if offline *) + } + + type domain_create_flag = + | START_PAUSED (** Launch guest in paused state *) + | START_AUTODESTROY (** Automatically kill guest on close *) + | START_BYPASS_CACHE (** Avoid filesystem cache pollution *) + | START_FORCE_BOOT (** Discard any managed save *) + | START_VALIDATE (** Validate XML against schema *) + + type sched_param = string * sched_param_value + and sched_param_value = + | SchedFieldInt32 of int32 | SchedFieldUInt32 of int32 + | SchedFieldInt64 of int64 | SchedFieldUInt64 of int64 + | SchedFieldFloat of float | SchedFieldBool of bool + + type typed_param = string * typed_param_value + and typed_param_value = + | TypedFieldInt32 of int32 | TypedFieldUInt32 of int32 + | TypedFieldInt64 of int64 | TypedFieldUInt64 of int64 + | TypedFieldFloat of float | TypedFieldBool of bool + | TypedFieldString of string + + type migrate_flag = Live + + type memory_flag = Virtual + + type list_flag = + | ListActive + | ListInactive + | ListAll + + type block_stats = { + rd_req : int64; + rd_bytes : int64; + wr_req : int64; + wr_bytes : int64; + errs : int64; + } + + type interface_stats = { + rx_bytes : int64; + rx_packets : int64; + rx_errs : int64; + rx_drop : int64; + tx_bytes : int64; + tx_packets : int64; + tx_errs : int64; + tx_drop : int64; + } + + type get_all_domain_stats_flag = + | GetAllDomainsStatsActive + | GetAllDomainsStatsInactive + | GetAllDomainsStatsOther + | GetAllDomainsStatsPaused + | GetAllDomainsStatsPersistent + | GetAllDomainsStatsRunning + | GetAllDomainsStatsShutoff + | GetAllDomainsStatsTransient + | GetAllDomainsStatsBacking + | GetAllDomainsStatsEnforceStats + + type stats_type = + | StatsState | StatsCpuTotal | StatsBalloon | StatsVcpu + | StatsInterface | StatsBlock | StatsPerf + + type domain_stats_record = { + dom_uuid : uuid; + params : typed_param array; + } + + type xml_desc_flag = + | XmlSecure (** dump security sensitive information too *) + | XmlInactive (** dump inactive domain information *) + | XmlUpdateCPU (** update guest CPU requirements according to host CPU *) + | XmlMigratable (** dump XML suitable for migration *) + + val max_peek : [>`R] t -> int + (** Maximum size supported by the {!block_peek} and {!memory_peek} + functions. If you want to peek more than this then you must + break your request into chunks. *) + + val create_linux : [>`W] Connect.t -> xml -> rw t + (** Create a new guest domain (not necessarily a Linux one) + from the given XML. + @deprecated Use {!create_xml} instead. + *) + val create_xml : [>`W] Connect.t -> xml -> domain_create_flag list -> rw t + (** Create a new guest domain from the given XML. *) + val lookup_by_id : 'a Connect.t -> int -> 'a t + (** Lookup a domain by ID. *) + val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t + (** Lookup a domain by UUID. This uses the packed byte array UUID. *) + val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t + (** Lookup a domain by (string) UUID. *) + val lookup_by_name : 'a Connect.t -> string -> 'a t + (** Lookup a domain by name. *) + val destroy : [>`W] t -> unit + (** Abruptly destroy a domain. *) + val free : [>`R] t -> unit + (** [free domain] frees the domain object in memory. + + The domain object is automatically freed if it is garbage + collected. This function just forces it to be freed right + away. + *) + + val suspend : [>`W] t -> unit + (** Suspend a domain. *) + val resume : [>`W] t -> unit + (** Resume a domain. *) + val save : [>`W] t -> filename -> unit + (** Suspend a domain, then save it to the file. *) + val restore : [>`W] Connect.t -> filename -> unit + (** Restore a domain from a file. *) + val core_dump : [>`W] t -> filename -> unit + (** Force a domain to core dump to the named file. *) + val shutdown : [>`W] t -> unit + (** Shutdown a domain. *) + val reboot : [>`W] t -> unit + (** Reboot a domain. *) + val get_name : [>`R] t -> string + (** Get the domain name. *) + val get_uuid : [>`R] t -> uuid + (** Get the domain UUID (as a packed byte array). *) + val get_uuid_string : [>`R] t -> string + (** Get the domain UUID (as a printable string). *) + val get_id : [>`R] t -> int + (** [get_id dom] returns the ID of the domain. In most cases + this returns [-1] if the domain is not running. *) + val get_os_type : [>`R] t -> string + (** Get the operating system type. *) + val get_max_memory : [>`R] t -> int64 + (** Get the maximum memory allocation. *) + val set_max_memory : [>`W] t -> int64 -> unit + (** Set the maximum memory allocation. *) + val set_memory : [>`W] t -> int64 -> unit + (** Set the normal memory allocation. *) + val get_info : [>`R] t -> info + (** Get information about a domain. *) + val get_xml_desc : [>`R] t -> xml + (** Get the XML description of a domain. *) + val get_xml_desc_flags : [>`W] t -> xml_desc_flag list -> xml + (** Get the XML description of a domain, with the possibility + to specify flags. *) + val get_scheduler_type : [>`R] t -> string * int + (** Get the scheduler type. *) + val get_scheduler_parameters : [>`R] t -> int -> sched_param array + (** Get the array of scheduler parameters. *) + val set_scheduler_parameters : [>`W] t -> sched_param array -> unit + (** Set the array of scheduler parameters. *) + val define_xml : [>`W] Connect.t -> xml -> rw t + (** Define a new domain (but don't start it up) from the XML. *) + val undefine : [>`W] t -> unit + (** Undefine a domain - removes its configuration. *) + val create : [>`W] t -> unit + (** Launch a defined (inactive) domain. *) + val get_autostart : [>`R] t -> bool + (** Get the autostart flag for a domain. *) + val set_autostart : [>`W] t -> bool -> unit + (** Set the autostart flag for a domain. *) + val set_vcpus : [>`W] t -> int -> unit + (** Change the number of vCPUs available to a domain. *) + val pin_vcpu : [>`W] t -> int -> string -> unit + (** [pin_vcpu dom vcpu bitmap] pins a domain vCPU to a bitmap of physical + CPUs. See the libvirt documentation for details of the + layout of the bitmap. *) + val get_vcpus : [>`R] t -> int -> int -> int * vcpu_info array * string + (** [get_vcpus dom maxinfo maplen] returns the pinning information + for a domain. See the libvirt documentation for details + of the array and bitmap returned from this function. + *) + val get_cpu_stats : [>`R] t -> typed_param list array + (** [get_pcpu_stats dom] returns the physical CPU stats + for a domain. See the libvirt documentation for details. + *) + val get_max_vcpus : [>`R] t -> int + (** Returns the maximum number of vCPUs supported for this domain. *) + val attach_device : [>`W] t -> xml -> unit + (** Attach a device (described by the device XML) to a domain. *) + val detach_device : [>`W] t -> xml -> unit + (** Detach a device (described by the device XML) from a domain. *) + + val migrate : [>`W] t -> [>`W] Connect.t -> migrate_flag list -> + ?dname:string -> ?uri:string -> ?bandwidth:int -> unit -> rw t + (** [migrate dom dconn flags ()] migrates a domain to a + destination host described by [dconn]. + + The optional flag [?dname] is used to rename the domain. + + The optional flag [?uri] is used to route the migration. + + The optional flag [?bandwidth] is used to limit the bandwidth + used for migration (in Mbps). *) + + val block_stats : [>`R] t -> string -> block_stats + (** Returns block device stats. *) + val interface_stats : [>`R] t -> string -> interface_stats + (** Returns network interface stats. *) + + val block_peek : [>`W] t -> string -> int64 -> int -> string -> int -> unit + (** [block_peek dom path offset size buf boff] reads [size] bytes at + [offset] in the domain's [path] block device. + + If successful then the data is written into [buf] starting + at offset [boff], for [size] bytes. + + See also {!max_peek}. *) + val memory_peek : [>`W] t -> memory_flag list -> int64 -> int -> + string -> int -> unit + (** [memory_peek dom Virtual offset size] reads [size] bytes + at [offset] in the domain's virtual memory. + + If successful then the data is written into [buf] starting + at offset [boff], for [size] bytes. + + See also {!max_peek}. *) + + external get_all_domain_stats : [>`R] Connect.t -> stats_type list -> get_all_domain_stats_flag list -> domain_stats_record array = "ocaml_libvirt_domain_get_all_domain_stats" + (** [get_all_domain_stats conn stats flags] allows you to read + all stats across multiple/all domains in a single call. + + See the libvirt documentation for + [virConnectGetAllDomainStats]. *) + + external const : [>`R] t -> ro t = "%identity" + (** [const dom] turns a read/write domain handle into a read-only + domain handle. Note that the opposite operation is impossible. + *) + + val get_domains : ([>`R] as 'a) Connect.t -> list_flag list -> 'a t list + (** Get the active and/or inactive domains using the most + efficient method available. + + See also: + {!get_domains_and_infos}, + {!Connect.list_domains}, + {!Connect.list_defined_domains}. + *) + + val get_domains_and_infos : ([>`R] as 'a) Connect.t -> list_flag list -> + ('a t * info) list + (** This gets the active and/or inactive domains and the + domain info for each one using the most efficient + method available. + + See also: + {!get_domains}, + {!Connect.list_domains}, + {!Connect.list_defined_domains}, + {!get_info}. + *) + +end + (** Module dealing with domains. [Domain.t] is the + domain object. *) + +module Event : +sig + + module Defined : sig + type t = [ + | `Added (** Newly created config file *) + | `Updated (** Changed config file *) + | `Unknown of int + ] + + val to_string: t -> string + end + + module Undefined : sig + type t = [ + | `Removed (** Deleted the config file *) + | `Unknown of int + ] + + val to_string: t -> string + end + + module Started : sig + type t = [ + | `Booted (** Normal startup from boot *) + | `Migrated (** Incoming migration from another host *) + | `Restored (** Restored from a state file *) + | `FromSnapshot (** Restored from snapshot *) + | `Wakeup (** Started due to wakeup event *) + | `Unknown of int + ] + + val to_string: t -> string + end + + module Suspended : sig + type t = [ + | `Paused (** Normal suspend due to admin pause *) + | `Migrated (** Suspended for offline migration *) + | `IOError (** Suspended due to a disk I/O error *) + | `Watchdog (** Suspended due to a watchdog firing *) + | `Restored (** Restored from paused state file *) + | `FromSnapshot (** Restored from paused snapshot *) + | `APIError (** suspended after failure during libvirt API call *) + | `Unknown of int + ] + + val to_string: t -> string + end + + module Resumed : sig + type t = [ + | `Unpaused (** Normal resume due to admin unpause *) + | `Migrated (** Resumed for completion of migration *) + | `FromSnapshot (** Resumed from snapshot *) + | `Unknown of int + ] + + val to_string: t -> string + end + + module Stopped : sig + type t = [ + | `Shutdown (** Normal shutdown *) + | `Destroyed (** Forced poweroff from host *) + | `Crashed (** Guest crashed *) + | `Migrated (** Migrated off to another host *) + | `Saved (** Saved to a state file *) + | `Failed (** Host emulator/mgmt failed *) + | `FromSnapshot (** offline snapshot loaded *) + | `Unknown of int + ] + + val to_string: t -> string + end + + module PM_suspended : sig + type t = [ + | `Memory (** Guest was PM suspended to memory *) + | `Disk (** Guest was PM suspended to disk *) + | `Unknown of int + ] + + val to_string: t -> string + end + + module Lifecycle : sig + type t = [ + | `Defined of Defined.t + | `Undefined of Undefined.t + | `Started of Started.t + | `Suspended of Suspended.t + | `Resumed of Resumed.t + | `Stopped of Stopped.t + | `Shutdown (* no detail defined yet *) + | `PMSuspended of PM_suspended.t + | `Unknown of int + ] + + val to_string: t -> string + end + + module Reboot : sig + type t = unit + + val to_string: t -> string + end + + module Rtc_change : sig + type t = int64 + + val to_string: t -> string + end + + module Watchdog : sig + type t = [ + | `None (** No action, watchdog ignored *) + | `Pause (** Guest CPUs are paused *) + | `Reset (** Guest CPUs are reset *) + | `Poweroff (** Guest is forcably powered off *) + | `Shutdown (** Guest is requested to gracefully shutdown *) + | `Debug (** No action, a debug message logged *) + | `Unknown of int (** newer libvirt *) + ] + + val to_string: t -> string + end + + module Io_error : sig + (** Represents both IOError and IOErrorReason *) + type action = [ + | `None (** No action, IO error ignored *) + | `Pause (** Guest CPUs are paused *) + | `Report (** IO error reported to guest OS *) + | `Unknown of int (** newer libvirt *) + ] + + type t = { + src_path: string option; (** The host file on which the I/O error occurred *) + dev_alias: string option; (** The guest device alias associated with the path *) + action: action; (** The action that is to be taken due to the IO error *) + reason: string option; (** The cause of the IO error *) + } + + val to_string: t -> string + end + + module Graphics_address : sig + type family = [ + | `Ipv4 (** IPv4 address *) + | `Ipv6 (** IPv6 address *) + | `Unix (** UNIX socket path *) + | `Unknown of int (** newer libvirt *) + ] + + type t = { + family: family; (** Address family *) + node: string option; (** Address of node (eg IP address, or UNIX path *) + service: string option; (** Service name/number (eg TCP port, or NULL) *) + } + + val to_string: t -> string + end + + module Graphics_subject : sig + type identity = { + ty: string option; (** Type of identity *) + name: string option; (** Identity value *) + } + + type t = identity list + + val to_string: t -> string + end + + module Graphics : sig + type phase = [ + | `Connect (** Initial socket connection established *) + | `Initialize (** Authentication & setup completed *) + | `Disconnect (** Final socket disconnection *) + | `Unknown of int (** newer libvirt *) + ] + + type t = { + phase: phase; (** the phase of the connection *) + local: Graphics_address.t; (** the local server address *) + remote: Graphics_address.t; (** the remote client address *) + auth_scheme: string option; (** the authentication scheme activated *) + subject: Graphics_subject.t; (** the authenticated subject (user) *) + } + + val to_string: t -> string + end + + module Control_error : sig + type t = unit + + val to_string: t -> string + end + + module Block_job : sig + type ty = [ + | `KnownUnknown (** explicitly named UNKNOWN in the spec *) + | `Pull + | `Copy + | `Commit + | `Unknown of int + ] + + type status = [ + | `Completed + | `Failed + | `Cancelled + | `Ready + | `Unknown of int + ] + + type t = { + disk: string option; (** fully-qualified name of the affected disk *) + ty: ty; (** type of block job *) + status: status; (** final status of the operation *) + } + + val to_string: t -> string + end + + module Disk_change : sig + type reason = [ + | `MissingOnStart + | `Unknown of int + ] + + type t = { + old_src_path: string option; (** old source path *) + new_src_path: string option; (** new source path *) + dev_alias: string option; (** device alias name *) + reason: reason; (** reason why this callback was called *) + } + + val to_string: t -> string + end + + module Tray_change : sig + type reason = [ + | `Open + | `Close + | `Unknown of int + ] + + type t = { + dev_alias: string option; (** device alias *) + reason: reason; (** why the tray status was changed *) + } + + val to_string: t -> string + end + + module PM_wakeup : sig + type reason = [ + | `Unknown of int + ] + + type t = reason + + val to_string: t -> string + end + + module PM_suspend : sig + type reason = [ + | `Unknown of int + ] + + type t = reason + + val to_string: t -> string + end + + module Balloon_change : sig + type t = int64 + + val to_string: t -> string + end + + module PM_suspend_disk : sig + type reason = [ + | `Unknown of int + ] + + type t = reason + + val to_string: t -> string + end + + + type callback = + | Lifecycle of ([`R] Domain.t -> Lifecycle.t -> unit) + | Reboot of ([`R] Domain.t -> Reboot.t -> unit) + | RtcChange of ([`R] Domain.t -> Rtc_change.t -> unit) + | Watchdog of ([`R] Domain.t -> Watchdog.t -> unit) + | IOError of ([`R] Domain.t -> Io_error.t -> unit) + | Graphics of ([`R] Domain.t -> Graphics.t -> unit) + | IOErrorReason of ([`R] Domain.t -> Io_error.t -> unit) + | ControlError of ([`R] Domain.t -> Control_error.t -> unit) + | BlockJob of ([`R] Domain.t -> Block_job.t -> unit) + | DiskChange of ([`R] Domain.t -> Disk_change.t -> unit) + | TrayChange of ([`R] Domain.t -> Tray_change.t -> unit) + | PMWakeUp of ([`R] Domain.t -> PM_wakeup.t -> unit) + | PMSuspend of ([`R] Domain.t -> PM_suspend.t -> unit) + | BalloonChange of ([`R] Domain.t -> Balloon_change.t -> unit) + | PMSuspendDisk of ([`R] Domain.t -> PM_suspend_disk.t -> unit) + + (** type of a registered call back function *) + + val register_default_impl : unit -> unit + (** Registers the default event loop based on poll(). This + must be done before connections are opened. + + Once registered call run_default_impl in a loop. *) + + val run_default_impl : unit -> unit + (** Runs one iteration of the event loop. Applications will + generally want to have a thread which invokes this in an + infinite loop. *) + + type callback_id + (** an individual event registration *) + + val register_any : 'a Connect.t -> ?dom:'a Domain.t -> callback -> callback_id + (** [register_any con ?dom callback] registers [callback] + to receive notification of arbitrary domain events. Return + a registration id which can be used in [deregister_any]. + + If [?dom] is [None] then register for this kind of event on + all domains. If [dom] is [Some d] then register for this + kind of event only on [d]. + *) + + val deregister_any : 'a Connect.t -> callback_id -> unit + (** [deregister_any con id] deregisters the previously registered + callback with id [id]. *) + + type timer_id + (** an individual timer event *) + + val add_timeout : 'a Connect.t -> int -> (unit -> unit) -> timer_id + (** [add_timeout con ms cb] registers [cb] as a timeout callback + which will be called every [ms] milliseconds *) + + val remove_timeout : 'a Connect.t -> timer_id -> unit + (** [remove_timeout con t] deregisters timeout callback [t]. *) + +end + (** Module dealing with events generated by domain + state changes. *) + +(** {3 Networks} *) + +module Network : +sig + type 'rw t + (** Network handle. Read-only handles have type [ro Network.t] and + read-write handles have type [rw Network.t]. + *) + + val lookup_by_name : 'a Connect.t -> string -> 'a t + (** Lookup a network by name. *) + val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t + (** Lookup a network by (packed) UUID. *) + val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t + (** Lookup a network by UUID string. *) + val create_xml : [>`W] Connect.t -> xml -> rw t + (** Create a network. *) + val define_xml : [>`W] Connect.t -> xml -> rw t + (** Define but don't activate a network. *) + val undefine : [>`W] t -> unit + (** Undefine configuration of a network. *) + val create : [>`W] t -> unit + (** Start up a defined (inactive) network. *) + val destroy : [>`W] t -> unit + (** Destroy a network. *) + val free : [>`R] t -> unit + (** [free network] frees the network object in memory. + + The network object is automatically freed if it is garbage + collected. This function just forces it to be freed right + away. + *) + + val get_name : [>`R] t -> string + (** Get network name. *) + val get_uuid : [>`R] t -> uuid + (** Get network packed UUID. *) + val get_uuid_string : [>`R] t -> string + (** Get network UUID as a printable string. *) + val get_xml_desc : [>`R] t -> xml + (** Get XML description of a network. *) + val get_bridge_name : [>`R] t -> string + (** Get bridge device name of a network. *) + val get_autostart : [>`R] t -> bool + (** Get the autostart flag for a network. *) + val set_autostart : [>`W] t -> bool -> unit + (** Set the autostart flag for a network. *) + + external const : [>`R] t -> ro t = "%identity" + (** [const network] turns a read/write network handle into a read-only + network handle. Note that the opposite operation is impossible. + *) +end + (** Module dealing with networks. [Network.t] is the + network object. *) + +(** {3 Storage pools} *) + +module Pool : +sig + type 'rw t + (** Storage pool handle. *) + + type pool_state = Inactive | Building | Running | Degraded | Inaccessible + (** State of the storage pool. *) + + type pool_build_flags = New | Repair | Resize + (** Flags for creating a storage pool. *) + + type pool_delete_flags = Normal | Zeroed + (** Flags for deleting a storage pool. *) + + type pool_info = { + state : pool_state; (** Pool state. *) + capacity : int64; (** Logical size in bytes. *) + allocation : int64; (** Currently allocated in bytes. *) + available : int64; (** Remaining free space bytes. *) + } + + val lookup_by_name : 'a Connect.t -> string -> 'a t + val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t + val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t + (** Look up a storage pool by name, UUID or UUID string. *) + + val create_xml : [>`W] Connect.t -> xml -> rw t + (** Create a storage pool. *) + val define_xml : [>`W] Connect.t -> xml -> rw t + (** Define but don't activate a storage pool. *) + val build : [>`W] t -> pool_build_flags -> unit + (** Build a storage pool. *) + val undefine : [>`W] t -> unit + (** Undefine configuration of a storage pool. *) + val create : [>`W] t -> unit + (** Start up a defined (inactive) storage pool. *) + val destroy : [>`W] t -> unit + (** Destroy a storage pool. *) + val delete : [>`W] t -> unit + (** Delete a storage pool. *) + val free : [>`R] t -> unit + (** Free a storage pool object in memory. + + The storage pool object is automatically freed if it is garbage + collected. This function just forces it to be freed right + away. + *) + val refresh : [`R] t -> unit + (** Refresh the list of volumes in the storage pool. *) + + val get_name : [`R] t -> string + (** Name of the pool. *) + val get_uuid : [`R] t -> uuid + (** Get the UUID (as a packed byte array). *) + val get_uuid_string : [`R] t -> string + (** Get the UUID (as a printable string). *) + val get_info : [`R] t -> pool_info + (** Get information about the pool. *) + val get_xml_desc : [`R] t -> xml + (** Get the XML description. *) + val get_autostart : [`R] t -> bool + (** Get the autostart flag for the storage pool. *) + val set_autostart : [>`W] t -> bool -> unit + (** Set the autostart flag for the storage pool. *) + + val num_of_volumes : [`R] t -> int + (** Returns the number of storage volumes within the storage pool. *) + val list_volumes : [`R] t -> int -> string array + (** Return list of storage volumes. *) + + external const : [>`R] t -> ro t = "%identity" + (** [const conn] turns a read/write storage pool into a read-only + pool. Note that the opposite operation is impossible. + *) +end + (** Module dealing with storage pools. *) + +(** {3 Storage volumes} *) + +module Volume : +sig + type 'rw t + (** Storage volume handle. *) + + type vol_type = File | Block | Dir | Network | NetDir | Ploop + (** Type of a storage volume. *) + + type vol_delete_flags = Normal | Zeroed + (** Flags for deleting a storage volume. *) + + type vol_info = { + typ : vol_type; (** Type of storage volume. *) + capacity : int64; (** Logical size in bytes. *) + allocation : int64; (** Currently allocated in bytes. *) + } + + val lookup_by_name : 'a Pool.t -> string -> 'a t + val lookup_by_key : 'a Connect.t -> string -> 'a t + val lookup_by_path : 'a Connect.t -> string -> 'a t + (** Look up a storage volume by name, key or path volume. *) + + val pool_of_volume : 'a t -> 'a Pool.t + (** Get the storage pool containing this volume. *) + + val get_name : [`R] t -> string + (** Name of the volume. *) + val get_key : [`R] t -> string + (** Key of the volume. *) + val get_path : [`R] t -> string + (** Path of the volume. *) + val get_info : [`R] t -> vol_info + (** Get information about the storage volume. *) + val get_xml_desc : [`R] t -> xml + (** Get the XML description. *) + + val create_xml : [>`W] Pool.t -> xml -> unit + (** Create a storage volume. *) + val delete : [>`W] t -> vol_delete_flags -> unit + (** Delete a storage volume. *) + val free : [>`R] t -> unit + (** Free a storage volume object in memory. + + The storage volume object is automatically freed if it is garbage + collected. This function just forces it to be freed right + away. + *) + + external const : [>`R] t -> ro t = "%identity" + (** [const conn] turns a read/write storage volume into a read-only + volume. Note that the opposite operation is impossible. + *) +end + (** Module dealing with storage volumes. *) + +(** {3 Secrets} *) + +module Secret : +sig + type 'rw t + (** Secret handle. *) + + type secret_usage_type = + | NoType + | Volume + | Ceph + | ISCSI + | TLS + (** Usage type of a secret. *) + + val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t + (** Lookup a secret by UUID. This uses the packed byte array UUID. *) + val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t + (** Lookup a secret by (string) UUID. *) + val lookup_by_usage : 'a Connect.t -> secret_usage_type -> string -> 'a t + (** Lookup a secret by usage type, and usage ID. *) + + val define_xml : [>`W] Connect.t -> xml -> rw t + (** Define a secret. *) + + val get_uuid : [>`R] t -> uuid + (** Get the UUID (as a packed byte array) of the secret. *) + val get_uuid_string : [>`R] t -> string + (** Get the UUID (as a printable string) of the secret. *) + val get_usage_type : [>`R] t -> secret_usage_type + (** Get the usage type of the secret. *) + val get_usage_id : [>`R] t -> string + (** Get the usage ID of the secret. *) + val get_xml_desc : [>`R] t -> xml + (** Get the XML description. *) + + val set_value : [>`W] t -> bytes -> unit + (** Set a new value for the secret. *) + val get_value : [>`R] t -> bytes + (** Get the value of the secret. *) + + val undefine : [>`W] t -> unit + (** Undefine a secret. *) + + val free : [>`R] t -> unit + (** Free a secret object in memory. + + The secret object is automatically freed if it is garbage + collected. This function just forces it to be freed right + away. + *) + + external const : [>`R] t -> ro t = "%identity" + (** [const conn] turns a read/write secret into a read-only + secret. Note that the opposite operation is impossible. + *) +end + (** Module dealing with secrets. *) + +(** {3 Error handling and exceptions} *) + +module Virterror : +sig + type code = + | VIR_ERR_OK + | VIR_ERR_INTERNAL_ERROR + | VIR_ERR_NO_MEMORY + | VIR_ERR_NO_SUPPORT + | VIR_ERR_UNKNOWN_HOST + | VIR_ERR_NO_CONNECT + | VIR_ERR_INVALID_CONN + | VIR_ERR_INVALID_DOMAIN + | VIR_ERR_INVALID_ARG + | VIR_ERR_OPERATION_FAILED + | VIR_ERR_GET_FAILED + | VIR_ERR_POST_FAILED + | VIR_ERR_HTTP_ERROR + | VIR_ERR_SEXPR_SERIAL + | VIR_ERR_NO_XEN + | VIR_ERR_XEN_CALL + | VIR_ERR_OS_TYPE + | VIR_ERR_NO_KERNEL + | VIR_ERR_NO_ROOT + | VIR_ERR_NO_SOURCE + | VIR_ERR_NO_TARGET + | VIR_ERR_NO_NAME + | VIR_ERR_NO_OS + | VIR_ERR_NO_DEVICE + | VIR_ERR_NO_XENSTORE + | VIR_ERR_DRIVER_FULL + | VIR_ERR_CALL_FAILED + | VIR_ERR_XML_ERROR + | VIR_ERR_DOM_EXIST + | VIR_ERR_OPERATION_DENIED + | VIR_ERR_OPEN_FAILED + | VIR_ERR_READ_FAILED + | VIR_ERR_PARSE_FAILED + | VIR_ERR_CONF_SYNTAX + | VIR_ERR_WRITE_FAILED + | VIR_ERR_XML_DETAIL + | VIR_ERR_INVALID_NETWORK + | VIR_ERR_NETWORK_EXIST + | VIR_ERR_SYSTEM_ERROR + | VIR_ERR_RPC + | VIR_ERR_GNUTLS_ERROR + | VIR_WAR_NO_NETWORK + | VIR_ERR_NO_DOMAIN + | VIR_ERR_NO_NETWORK + | VIR_ERR_INVALID_MAC + | VIR_ERR_AUTH_FAILED + | VIR_ERR_INVALID_STORAGE_POOL + | VIR_ERR_INVALID_STORAGE_VOL + | VIR_WAR_NO_STORAGE + | VIR_ERR_NO_STORAGE_POOL + | VIR_ERR_NO_STORAGE_VOL + | VIR_WAR_NO_NODE + | VIR_ERR_INVALID_NODE_DEVICE + | VIR_ERR_NO_NODE_DEVICE + | VIR_ERR_NO_SECURITY_MODEL + | VIR_ERR_OPERATION_INVALID + | VIR_WAR_NO_INTERFACE + | VIR_ERR_NO_INTERFACE + | VIR_ERR_INVALID_INTERFACE + | VIR_ERR_MULTIPLE_INTERFACES + | VIR_WAR_NO_NWFILTER + | VIR_ERR_INVALID_NWFILTER + | VIR_ERR_NO_NWFILTER + | VIR_ERR_BUILD_FIREWALL + | VIR_WAR_NO_SECRET + | VIR_ERR_INVALID_SECRET + | VIR_ERR_NO_SECRET + | VIR_ERR_CONFIG_UNSUPPORTED + | VIR_ERR_OPERATION_TIMEOUT + | VIR_ERR_MIGRATE_PERSIST_FAILED + | VIR_ERR_HOOK_SCRIPT_FAILED + | VIR_ERR_INVALID_DOMAIN_SNAPSHOT + | VIR_ERR_NO_DOMAIN_SNAPSHOT + | VIR_ERR_INVALID_STREAM + | VIR_ERR_ARGUMENT_UNSUPPORTED + | VIR_ERR_STORAGE_PROBE_FAILED + | VIR_ERR_STORAGE_POOL_BUILT + | VIR_ERR_SNAPSHOT_REVERT_RISKY + | VIR_ERR_OPERATION_ABORTED + | VIR_ERR_AUTH_CANCELLED + | VIR_ERR_NO_DOMAIN_METADATA + | VIR_ERR_MIGRATE_UNSAFE + | VIR_ERR_OVERFLOW + | VIR_ERR_BLOCK_COPY_ACTIVE + | VIR_ERR_OPERATION_UNSUPPORTED + | VIR_ERR_SSH + | VIR_ERR_AGENT_UNRESPONSIVE + | VIR_ERR_RESOURCE_BUSY + | VIR_ERR_ACCESS_DENIED + | VIR_ERR_DBUS_SERVICE + | VIR_ERR_STORAGE_VOL_EXIST + | VIR_ERR_CPU_INCOMPATIBLE + | VIR_ERR_XML_INVALID_SCHEMA + | VIR_ERR_MIGRATE_FINISH_OK + | VIR_ERR_AUTH_UNAVAILABLE + | VIR_ERR_NO_SERVER + | VIR_ERR_NO_CLIENT + | VIR_ERR_AGENT_UNSYNCED + | VIR_ERR_LIBSSH + | VIR_ERR_DEVICE_MISSING + | VIR_ERR_INVALID_NWFILTER_BINDING + | VIR_ERR_NO_NWFILTER_BINDING + (* ^^ NB: If you add a variant you MUST edit + libvirt_c_epilogue.c:MAX_VIR_* *) + | VIR_ERR_UNKNOWN of int (** Other error, not handled with existing values. *) + (** See [<libvirt/virterror.h>] for meaning of these codes. *) + + val string_of_code : code -> string + + type domain = + | VIR_FROM_NONE + | VIR_FROM_XEN + | VIR_FROM_XEND + | VIR_FROM_XENSTORE + | VIR_FROM_SEXPR + | VIR_FROM_XML + | VIR_FROM_DOM + | VIR_FROM_RPC + | VIR_FROM_PROXY + | VIR_FROM_CONF + | VIR_FROM_QEMU + | VIR_FROM_NET + | VIR_FROM_TEST + | VIR_FROM_REMOTE + | VIR_FROM_OPENVZ + | VIR_FROM_XENXM + | VIR_FROM_STATS_LINUX + | VIR_FROM_LXC + | VIR_FROM_STORAGE + | VIR_FROM_NETWORK + | VIR_FROM_DOMAIN + | VIR_FROM_UML + | VIR_FROM_NODEDEV + | VIR_FROM_XEN_INOTIFY + | VIR_FROM_SECURITY + | VIR_FROM_VBOX + | VIR_FROM_INTERFACE + | VIR_FROM_ONE + | VIR_FROM_ESX + | VIR_FROM_PHYP + | VIR_FROM_SECRET + | VIR_FROM_CPU + | VIR_FROM_XENAPI + | VIR_FROM_NWFILTER + | VIR_FROM_HOOK + | VIR_FROM_DOMAIN_SNAPSHOT + | VIR_FROM_AUDIT + | VIR_FROM_SYSINFO + | VIR_FROM_STREAMS + | VIR_FROM_VMWARE + | VIR_FROM_EVENT + | VIR_FROM_LIBXL + | VIR_FROM_LOCKING + | VIR_FROM_HYPERV + | VIR_FROM_CAPABILITIES + | VIR_FROM_URI + | VIR_FROM_AUTH + | VIR_FROM_DBUS + | VIR_FROM_PARALLELS + | VIR_FROM_DEVICE + | VIR_FROM_SSH + | VIR_FROM_LOCKSPACE + | VIR_FROM_INITCTL + | VIR_FROM_IDENTITY + | VIR_FROM_CGROUP + | VIR_FROM_ACCESS + | VIR_FROM_SYSTEMD + | VIR_FROM_BHYVE + | VIR_FROM_CRYPTO + | VIR_FROM_FIREWALL + | VIR_FROM_POLKIT + | VIR_FROM_THREAD + | VIR_FROM_ADMIN + | VIR_FROM_LOGGING + | VIR_FROM_XENXL + | VIR_FROM_PERF + | VIR_FROM_LIBSSH + | VIR_FROM_RESCTRL + (* ^^ NB: If you add a variant you MUST edit + libvirt_c_epilogue.c: MAX_VIR_* *) + | VIR_FROM_UNKNOWN of int (** Other domain, not handled with existing values. *) + (** Subsystem / driver which produced the error. *) + + val string_of_domain : domain -> string + + type level = + | VIR_ERR_NONE + | VIR_ERR_WARNING + | VIR_ERR_ERROR + (* ^^ NB: If you add a variant you MUST edit libvirt_c.c: MAX_VIR_* *) + | VIR_ERR_UNKNOWN_LEVEL of int (** Other level, not handled with existing values. *) + (** No error, a warning or an error. *) + + val string_of_level : level -> string + + type t = { + code : code; (** Error code. *) + domain : domain; (** Origin of the error. *) + message : string option; (** Human-readable message. *) + level : level; (** Error or warning. *) + str1 : string option; (** Informational string. *) + str2 : string option; (** Informational string. *) + str3 : string option; (** Informational string. *) + int1 : int32; (** Informational integer. *) + int2 : int32; (** Informational integer. *) + } + (** An error object. *) + + val to_string : t -> string + (** Turn the exception into a printable string. *) + + val get_last_error : unit -> t option + val get_last_conn_error : [>`R] Connect.t -> t option + (** Get the last error at a global or connection level. + + Normally you do not need to use these functions because + the library automatically turns errors into exceptions. + *) + + val reset_last_error : unit -> unit + val reset_last_conn_error : [>`R] Connect.t -> unit + (** Reset the error at a global or connection level. + + Normally you do not need to use these functions. + *) + + val no_error : unit -> t + (** Creates an empty error message. + + Normally you do not need to use this function. + *) +end + (** Module dealing with errors. *) + +exception Virterror of Virterror.t +(** This exception can be raised by any library function that detects + an error. To get a printable error message, call + {!Virterror.to_string} on the content of this exception. +*) + +exception Not_supported of string +(** + Functions may raise + [Not_supported "virFoo"] + (where [virFoo] is the libvirt function name) if a function is + not supported at either compile or run time. This applies to + any libvirt function added after version 0.2.1. + + See also {{:https://libvirt.org/hvsupport.html}https://libvirt.org/hvsupport.html} +*) + +(** {3 Utility functions} *) + +val map_ignore_errors : ('a -> 'b) -> 'a list -> 'b list +(** [map_ignore_errors f xs] calls function [f] for each element of [xs]. + + This is just like [List.map] except that if [f x] throws a + {!Virterror.t} exception, the error is ignored and [f x] + is not returned in the final list. + + This function is primarily useful when dealing with domains which + might 'disappear' asynchronously from the currently running + program. +*) diff --git a/common/mllibvirt/libvirt_c_epilogue.c b/common/mllibvirt/libvirt_c_epilogue.c new file mode 100644 index 000000000..4e75d2f34 --- /dev/null +++ b/common/mllibvirt/libvirt_c_epilogue.c @@ -0,0 +1,462 @@ +/* OCaml bindings for libvirt. + * (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + * https://libvirt.org/ + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2 of the License, or (at your option) any later version, + * with the OCaml linking exception described in ../COPYING.LIB. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +/* Please read libvirt/README file. */ + +static const char * +Optstring_val (value strv) +{ + if (strv == Val_int (0)) /* None */ + return NULL; + else /* Some string */ + return String_val (Field (strv, 0)); +} + +static value +Val_opt (void *ptr, Val_ptr_t Val_ptr) +{ + CAMLparam0 (); + CAMLlocal2 (optv, ptrv); + + if (ptr) { /* Some ptr */ + optv = caml_alloc (1, 0); + ptrv = Val_ptr (ptr); + Store_field (optv, 0, ptrv); + } else /* None */ + optv = Val_int (0); + + CAMLreturn (optv); +} + +static value +Val_opt_const (const void *ptr, Val_const_ptr_t Val_ptr) +{ + CAMLparam0 (); + CAMLlocal2 (optv, ptrv); + + if (ptr) { /* Some ptr */ + optv = caml_alloc (1, 0); + ptrv = Val_ptr (ptr); + Store_field (optv, 0, ptrv); + } else /* None */ + optv = Val_int (0); + + CAMLreturn (optv); +} + +#if 0 +static value +option_default (value option, value deflt) +{ + if (option == Val_int (0)) /* "None" */ + return deflt; + else /* "Some 'a" */ + return Field (option, 0); +} +#endif + +static void +_raise_virterror (const char *fn) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + virErrorPtr errp; + struct _virError err; + + errp = virGetLastError (); + + if (!errp) { + /* Fake a _virError structure. */ + memset (&err, 0, sizeof err); + err.code = VIR_ERR_INTERNAL_ERROR; + err.domain = VIR_FROM_NONE; + err.level = VIR_ERR_ERROR; + err.message = (char *) fn; + errp = &err; + } + + rv = Val_virterror (errp); + caml_raise_with_arg (*caml_named_value ("ocaml_libvirt_virterror"), rv); + + /*NOTREACHED*/ + /* Suppresses a compiler warning. */ + (void) caml__frame; +} + +static int +_list_length (value listv) +{ + CAMLparam1 (listv); + int len = 0; + + for (; listv != Val_emptylist; listv = Field (listv, 1), ++len) {} + + CAMLreturnT (int, len); +} + +static value +Val_virconnectcredential (const virConnectCredentialPtr cred) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + + rv = caml_alloc (4, 0); + Store_field (rv, 0, Val_int (cred->type - 1)); + Store_field (rv, 1, caml_copy_string (cred->prompt)); + Store_field (rv, 2, + Val_opt_const (cred->challenge, + (Val_const_ptr_t) caml_copy_string)); + Store_field (rv, 3, + Val_opt_const (cred->defresult, + (Val_const_ptr_t) caml_copy_string)); + + CAMLreturn (rv); +} + +/* Convert the virErrorNumber, virErrorDomain and virErrorLevel enums + * into values (longs because they are variants in OCaml). + * + * The enum values are part of the libvirt ABI so they cannot change, + * which means that we can convert these numbers directly into + * OCaml variants (which use the same ordering) very fast. + * + * The tricky part here is when we are linked to a newer version of + * libvirt than the one we were compiled against. If the newer libvirt + * generates an error code which we don't know about then we need + * to convert it into VIR_*_UNKNOWN (code). + */ + +#define MAX_VIR_CODE 101 /* VIR_ERR_NO_NWFILTER_BINDING */ +#define MAX_VIR_DOMAIN 67 /* VIR_FROM_RESCTRL */ +#define MAX_VIR_LEVEL VIR_ERR_ERROR + +static inline value +Val_err_number (virErrorNumber code) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + + if (0 <= (int) code && code <= MAX_VIR_CODE) + rv = Val_int (code); + else { + rv = caml_alloc (1, 0); /* VIR_ERR_UNKNOWN (code) */ + Store_field (rv, 0, Val_int (code)); + } + + CAMLreturn (rv); +} + +static inline value +Val_err_domain (virErrorDomain code) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + + if (0 <= (int) code && code <= MAX_VIR_DOMAIN) + rv = Val_int (code); + else { + rv = caml_alloc (1, 0); /* VIR_FROM_UNKNOWN (code) */ + Store_field (rv, 0, Val_int (code)); + } + + CAMLreturn (rv); +} + +static inline value +Val_err_level (virErrorLevel code) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + + if (0 <= (int) code && code <= MAX_VIR_LEVEL) + rv = Val_int (code); + else { + rv = caml_alloc (1, 0); /* VIR_ERR_UNKNOWN_LEVEL (code) */ + Store_field (rv, 0, Val_int (code)); + } + + CAMLreturn (rv); +} + +/* Convert a virterror to a value. */ +static value +Val_virterror (virErrorPtr err) +{ + CAMLparam0 (); + CAMLlocal3 (rv, connv, optv); + + rv = caml_alloc (9, 0); + Store_field (rv, 0, Val_err_number (err->code)); + Store_field (rv, 1, Val_err_domain (err->domain)); + Store_field (rv, 2, + Val_opt (err->message, (Val_ptr_t) caml_copy_string)); + Store_field (rv, 3, Val_err_level (err->level)); + + Store_field (rv, 4, + Val_opt (err->str1, (Val_ptr_t) caml_copy_string)); + Store_field (rv, 5, + Val_opt (err->str2, (Val_ptr_t) caml_copy_string)); + Store_field (rv, 6, + Val_opt (err->str3, (Val_ptr_t) caml_copy_string)); + Store_field (rv, 7, caml_copy_int32 (err->int1)); + Store_field (rv, 8, caml_copy_int32 (err->int2)); + + CAMLreturn (rv); +} + +static void conn_finalize (value); +static void dom_finalize (value); +static void net_finalize (value); +static void pol_finalize (value); +static void vol_finalize (value); +static void sec_finalize (value); + +static struct custom_operations conn_custom_operations = { + (char *) "conn_custom_operations", + conn_finalize, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + +static struct custom_operations dom_custom_operations = { + (char *) "dom_custom_operations", + dom_finalize, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default + +}; + +static struct custom_operations net_custom_operations = { + (char *) "net_custom_operations", + net_finalize, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + +static struct custom_operations pol_custom_operations = { + (char *) "pol_custom_operations", + pol_finalize, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + +static struct custom_operations vol_custom_operations = { + (char *) "vol_custom_operations", + vol_finalize, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + +static struct custom_operations sec_custom_operations = { + (char *) "sec_custom_operations", + sec_finalize, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + +static value +Val_connect (virConnectPtr conn) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + rv = caml_alloc_custom (&conn_custom_operations, + sizeof (virConnectPtr), 0, 1); + Connect_val (rv) = conn; + CAMLreturn (rv); +} + +static value +Val_dom (virDomainPtr dom) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + rv = caml_alloc_custom (&dom_custom_operations, + sizeof (virDomainPtr), 0, 1); + Dom_val (rv) = dom; + CAMLreturn (rv); +} + +static value +Val_net (virNetworkPtr net) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + rv = caml_alloc_custom (&net_custom_operations, + sizeof (virNetworkPtr), 0, 1); + Net_val (rv) = net; + CAMLreturn (rv); +} + +static value +Val_pol (virStoragePoolPtr pol) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + rv = caml_alloc_custom (&pol_custom_operations, + sizeof (virStoragePoolPtr), 0, 1); + Pol_val (rv) = pol; + CAMLreturn (rv); +} + +static value +Val_vol (virStorageVolPtr vol) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + rv = caml_alloc_custom (&vol_custom_operations, + sizeof (virStorageVolPtr), 0, 1); + Vol_val (rv) = vol; + CAMLreturn (rv); +} + +static value +Val_sec (virSecretPtr sec) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + rv = caml_alloc_custom (&sec_custom_operations, + sizeof (virSecretPtr), 0, 1); + Sec_val (rv) = sec; + CAMLreturn (rv); +} + +/* This wraps up the (dom, conn) pair (Domain.t). */ +static value +Val_domain (virDomainPtr dom, value connv) +{ + CAMLparam1 (connv); + CAMLlocal2 (rv, v); + + rv = caml_alloc_tuple (2); + v = Val_dom (dom); + Store_field (rv, 0, v); + Store_field (rv, 1, connv); + CAMLreturn (rv); +} + +/* This wraps up the (net, conn) pair (Network.t). */ +static value +Val_network (virNetworkPtr net, value connv) +{ + CAMLparam1 (connv); + CAMLlocal2 (rv, v); + + rv = caml_alloc_tuple (2); + v = Val_net (net); + Store_field (rv, 0, v); + Store_field (rv, 1, connv); + CAMLreturn (rv); +} + +/* This wraps up the (pol, conn) pair (Pool.t). */ +static value +Val_pool (virStoragePoolPtr pol, value connv) +{ + CAMLparam1 (connv); + CAMLlocal2 (rv, v); + + rv = caml_alloc_tuple (2); + v = Val_pol (pol); + Store_field (rv, 0, v); + Store_field (rv, 1, connv); + CAMLreturn (rv); +} + +/* This wraps up the (vol, conn) pair (Volume.t). */ +static value +Val_volume (virStorageVolPtr vol, value connv) +{ + CAMLparam1 (connv); + CAMLlocal2 (rv, v); + + rv = caml_alloc_tuple (2); + v = Val_vol (vol); + Store_field (rv, 0, v); + Store_field (rv, 1, connv); + CAMLreturn (rv); +} + +/* This wraps up the (sec, conn) pair (Secret.t). */ +static value +Val_secret (virSecretPtr sec, value connv) +{ + CAMLparam1 (connv); + CAMLlocal2 (rv, v); + + rv = caml_alloc_tuple (2); + v = Val_sec (sec); + Store_field (rv, 0, v); + Store_field (rv, 1, connv); + CAMLreturn (rv); +} + +static void +conn_finalize (value connv) +{ + virConnectPtr conn = Connect_val (connv); + if (conn) (void) virConnectClose (conn); +} + +static void +dom_finalize (value domv) +{ + virDomainPtr dom = Dom_val (domv); + if (dom) (void) virDomainFree (dom); +} + +static void +net_finalize (value netv) +{ + virNetworkPtr net = Net_val (netv); + if (net) (void) virNetworkFree (net); +} + +static void +pol_finalize (value polv) +{ + virStoragePoolPtr pol = Pol_val (polv); + if (pol) (void) virStoragePoolFree (pol); +} + +static void +vol_finalize (value volv) +{ + virStorageVolPtr vol = Vol_val (volv); + if (vol) (void) virStorageVolFree (vol); +} + +static void +sec_finalize (value secv) +{ + virSecretPtr sec = Sec_val (secv); + if (sec) (void) virSecretFree (sec); +} diff --git a/common/mllibvirt/libvirt_c_oneoffs.c b/common/mllibvirt/libvirt_c_oneoffs.c new file mode 100644 index 000000000..71ca78e98 --- /dev/null +++ b/common/mllibvirt/libvirt_c_oneoffs.c @@ -0,0 +1,1698 @@ +/* OCaml bindings for libvirt. + * (C) Copyright 2007-2017 Richard W.M. Jones, Red Hat Inc. + * https://libvirt.org/ + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +/* Please read libvirt/README file. */ + +#ifdef __GNUC__ +#pragma GCC diagnostic ignored "-Wmissing-prototypes" +#endif + +/*----------------------------------------------------------------------*/ + +CAMLprim value +ocaml_libvirt_get_version (value driverv, value unit) +{ + CAMLparam2 (driverv, unit); + CAMLlocal1 (rv); + const char *driver = Optstring_val (driverv); + unsigned long libVer, typeVer = 0, *typeVer_ptr; + int r; + + typeVer_ptr = driver ? &typeVer : NULL; + NONBLOCKING (r = virGetVersion (&libVer, driver, typeVer_ptr)); + CHECK_ERROR (r == -1, "virGetVersion"); + + rv = caml_alloc_tuple (2); + Store_field (rv, 0, Val_int (libVer)); + Store_field (rv, 1, Val_int (typeVer)); + CAMLreturn (rv); +} + +/*----------------------------------------------------------------------*/ + +/* Connection object. */ + +CAMLprim value +ocaml_libvirt_connect_open (value namev, value unit) +{ + CAMLparam2 (namev, unit); + CAMLlocal1 (rv); + const char *name = Optstring_val (namev); + virConnectPtr conn; + + NONBLOCKING (conn = virConnectOpen (name)); + CHECK_ERROR (!conn, "virConnectOpen"); + + rv = Val_connect (conn); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_connect_open_readonly (value namev, value unit) +{ + CAMLparam2 (namev, unit); + CAMLlocal1 (rv); + const char *name = Optstring_val (namev); + virConnectPtr conn; + + NONBLOCKING (conn = virConnectOpenReadOnly (name)); + CHECK_ERROR (!conn, "virConnectOpen"); + + rv = Val_connect (conn); + + CAMLreturn (rv); +} + +/* Helper struct holding data needed for the helper C authentication + * callback (which will call the actual OCaml callback). + */ +struct ocaml_auth_callback_data { + value *fvp; /* The OCaml auth callback. */ +}; + +static int +_ocaml_auth_callback (virConnectCredentialPtr cred, unsigned int ncred, void *cbdata) +{ + CAMLparam0 (); + CAMLlocal4 (listv, elemv, rv, v); + struct ocaml_auth_callback_data *s = cbdata; + int i, len; + + listv = Val_emptylist; + for (i = ncred - 1; i >= 0; --i) { + elemv = caml_alloc (2, 0); + Store_field (elemv, 0, Val_virconnectcredential (&cred[i])); + Store_field (elemv, 1, listv); + listv = elemv; + } + + /* Call the auth callback. */ + rv = caml_callback_exn (*s->fvp, listv); + if (Is_exception_result (rv)) { + /* The callback raised an exception, so return an error. */ + CAMLreturnT (int, -1); + } + + len = _list_length (rv); + if (len != (int) ncred) { + /* The callback did not return the same number of results as the + * credentials. + */ + CAMLreturnT (int, -1); + } + + for (i = 0; rv != Val_emptylist; rv = Field (rv, 1), ++i) { + virConnectCredentialPtr c = &cred[i]; + elemv = Field (rv, 0); + if (elemv == Val_int (0)) { + c->result = NULL; + c->resultlen = 0; + } else { + v = Field (elemv, 0); + len = caml_string_length (v); + c->result = malloc (len + 1); + if (c->result == NULL) + CAMLreturnT (int, -1); + memcpy (c->result, String_val (v), len); + c->result[len] = '\0'; + c->resultlen = len; + } + } + + CAMLreturnT (int, 0); +} + +static virConnectPtr +_ocaml_libvirt_connect_open_auth_common (value namev, value authv, int flags) +{ + CAMLparam2 (namev, authv); + CAMLlocal2 (listv, fv); + virConnectPtr conn; + virConnectAuth auth; + struct ocaml_auth_callback_data data; + int i; + char *name = NULL; + + /* Keep a copy of the 'namev' string, as its value could move around + * when calling other OCaml code that allocates memory. + */ + if (namev != Val_int (0)) { /* Some string */ + name = strdup (String_val (Field (namev, 0))); + if (name == NULL) + caml_raise_out_of_memory (); + } + + fv = Field (authv, 1); + data.fvp = &fv; + + listv = Field (authv, 0); + auth.ncredtype = _list_length (listv); + auth.credtype = malloc (sizeof (int) * auth.ncredtype); + if (auth.credtype == NULL) + caml_raise_out_of_memory (); + for (i = 0; listv != Val_emptylist; listv = Field (listv, 1), ++i) { + auth.credtype[i] = Int_val (Field (listv, 0)) + 1; + } + auth.cb = &_ocaml_auth_callback; + auth.cbdata = &data; + + /* Call virConnectOpenAuth directly, without using the NONBLOCKING + * macro, as this will indeed call ocaml_* APIs, and run OCaml code. + */ + conn = virConnectOpenAuth (name, &auth, flags); + free (auth.credtype); + free (name); + CHECK_ERROR (!conn, "virConnectOpenAuth"); + + CAMLreturnT (virConnectPtr, conn); +} + +CAMLprim value +ocaml_libvirt_connect_open_auth (value namev, value authv) +{ + CAMLparam2 (namev, authv); + CAMLlocal1 (rv); + virConnectPtr conn; + + conn = _ocaml_libvirt_connect_open_auth_common (namev, authv, 0); + rv = Val_connect (conn); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_connect_open_auth_readonly (value namev, value authv) +{ + CAMLparam2 (namev, authv); + CAMLlocal1 (rv); + virConnectPtr conn; + + conn = _ocaml_libvirt_connect_open_auth_common (namev, authv, VIR_CONNECT_RO); + rv = Val_connect (conn); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_connect_get_version (value connv) +{ + CAMLparam1 (connv); + virConnectPtr conn = Connect_val (connv); + unsigned long hvVer; + int r; + + NONBLOCKING (r = virConnectGetVersion (conn, &hvVer)); + CHECK_ERROR (r == -1, "virConnectGetVersion"); + + CAMLreturn (Val_int (hvVer)); +} + +CAMLprim value +ocaml_libvirt_connect_get_max_vcpus (value connv, value typev) +{ + CAMLparam2 (connv, typev); + virConnectPtr conn = Connect_val (connv); + const char *type = Optstring_val (typev); + int r; + + NONBLOCKING (r = virConnectGetMaxVcpus (conn, type)); + CHECK_ERROR (r == -1, "virConnectGetMaxVcpus"); + + CAMLreturn (Val_int (r)); +} + +CAMLprim value +ocaml_libvirt_connect_get_node_info (value connv) +{ + CAMLparam1 (connv); + CAMLlocal2 (rv, v); + virConnectPtr conn = Connect_val (connv); + virNodeInfo info; + int r; + + NONBLOCKING (r = virNodeGetInfo (conn, &info)); + CHECK_ERROR (r == -1, "virNodeGetInfo"); + + rv = caml_alloc (8, 0); + v = caml_copy_string (info.model); Store_field (rv, 0, v); + v = caml_copy_int64 (info.memory); Store_field (rv, 1, v); + Store_field (rv, 2, Val_int (info.cpus)); + Store_field (rv, 3, Val_int (info.mhz)); + Store_field (rv, 4, Val_int (info.nodes)); + Store_field (rv, 5, Val_int (info.sockets)); + Store_field (rv, 6, Val_int (info.cores)); + Store_field (rv, 7, Val_int (info.threads)); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_connect_node_get_free_memory (value connv) +{ + CAMLparam1 (connv); + CAMLlocal1 (rv); + virConnectPtr conn = Connect_val (connv); + unsigned long long r; + + NONBLOCKING (r = virNodeGetFreeMemory (conn)); + CHECK_ERROR (r == 0, "virNodeGetFreeMemory"); + + rv = caml_copy_int64 ((int64_t) r); + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_connect_node_get_cells_free_memory (value connv, + value startv, value maxv) +{ + CAMLparam3 (connv, startv, maxv); + CAMLlocal2 (rv, iv); + virConnectPtr conn = Connect_val (connv); + int start = Int_val (startv); + int max = Int_val (maxv); + int r, i; + unsigned long long *freemems; + + freemems = malloc(sizeof (*freemems) * max); + if (freemems == NULL) + caml_raise_out_of_memory (); + + NONBLOCKING (r = virNodeGetCellsFreeMemory (conn, freemems, start, max)); + CHECK_ERROR_CLEANUP (r == -1, free (freemems), "virNodeGetCellsFreeMemory"); + + rv = caml_alloc (r, 0); + for (i = 0; i < r; ++i) { + iv = caml_copy_int64 ((int64_t) freemems[i]); + Store_field (rv, i, iv); + } + free (freemems); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_connect_set_keep_alive(value connv, + value intervalv, value countv) +{ + CAMLparam3 (connv, intervalv, countv); + virConnectPtr conn = Connect_val(connv); + int interval = Int_val(intervalv); + unsigned int count = Int_val(countv); + int r; + + NONBLOCKING(r = virConnectSetKeepAlive(conn, interval, count)); + CHECK_ERROR (r == -1, "virConnectSetKeepAlive"); + + CAMLreturn(Val_unit); +} + +CAMLprim value +ocaml_libvirt_connect_credtypes_from_auth_default (value unitv) +{ + CAMLparam1 (unitv); + CAMLlocal2 (listv, itemv); + int i; + + listv = Val_emptylist; + + if (virConnectAuthPtrDefault) { + for (i = virConnectAuthPtrDefault->ncredtype; i >= 0; --i) { + const int type = virConnectAuthPtrDefault->credtype[i]; + itemv = caml_alloc (2, 0); + Store_field (itemv, 0, Val_int (type - 1)); + Store_field (itemv, 1, listv); + listv = itemv; + } + } + + CAMLreturn (listv); +} + +CAMLprim value +ocaml_libvirt_connect_call_auth_default_callback (value listv) +{ + CAMLparam1 (listv); + CAMLlocal5 (credv, retv, elemv, optv, v); + int i, len, ret; + const char *str; + virConnectCredentialPtr creds; + + if (virConnectAuthPtrDefault == NULL + || virConnectAuthPtrDefault->cb == NULL) + CAMLreturn (Val_unit); + + len = _list_length (listv); + creds = calloc (len, sizeof (*creds)); + if (creds == NULL) + caml_raise_out_of_memory (); + for (i = 0; listv != Val_emptylist; listv = Field (listv, 1), ++i) { + virConnectCredentialPtr cred = &creds[i]; + credv = Field (listv, 0); + cred->type = Int_val (Field (credv, 0)) + 1; + cred->prompt = strdup (String_val (Field (credv, 1))); + if (cred->prompt == NULL) + caml_raise_out_of_memory (); + str = Optstring_val (Field (credv, 2)); + if (str) { + cred->challenge = strdup (str); + if (cred->challenge == NULL) + caml_raise_out_of_memory (); + } + str = Optstring_val (Field (credv, 3)); + if (str) { + cred->defresult = strdup (str); + if (cred->defresult == NULL) + caml_raise_out_of_memory (); + } + } + + ret = virConnectAuthPtrDefault->cb (creds, len, + virConnectAuthPtrDefault->cbdata); + if (ret >= 0) { + retv = Val_emptylist; + for (i = len - 1; i >= 0; --i) { + virConnectCredentialPtr cred = &creds[i]; + elemv = caml_alloc (2, 0); + if (cred->result != NULL && cred->resultlen > 0) { + v = caml_alloc_string (cred->resultlen); + memcpy (String_val (v), cred->result, cred->resultlen); + optv = caml_alloc (1, 0); + Store_field (optv, 0, v); + } else + optv = Val_int (0); + Store_field (elemv, 0, optv); + Store_field (elemv, 1, retv); + retv = elemv; + } + } + for (i = 0; i < len; ++i) { + virConnectCredentialPtr cred = &creds[i]; + /* Cast to char *, as the virConnectCredential structs we fill have + * const char * qualifiers. + */ + free ((char *) cred->prompt); + free ((char *) cred->challenge); + free ((char *) cred->defresult); + } + free (creds); + + if (ret < 0) + caml_failwith ("virConnectAuthPtrDefault callback failed"); + + CAMLreturn (retv); +} + +CAMLprim value +ocaml_libvirt_domain_get_id (value domv) +{ + CAMLparam1 (domv); + virDomainPtr dom = Domain_val (domv); + unsigned int r; + + NONBLOCKING (r = virDomainGetID (dom)); + /* In theory this could return -1 on error, but in practice + * libvirt never does this unless you call it with a corrupted + * or NULL dom object. So ignore errors here. + */ + + CAMLreturn (Val_int ((int) r)); +} + +CAMLprim value +ocaml_libvirt_domain_get_max_memory (value domv) +{ + CAMLparam1 (domv); + CAMLlocal1 (rv); + virDomainPtr dom = Domain_val (domv); + unsigned long r; + + NONBLOCKING (r = virDomainGetMaxMemory (dom)); + CHECK_ERROR (r == 0 /* [sic] */, "virDomainGetMaxMemory"); + + rv = caml_copy_int64 (r); + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_domain_set_max_memory (value domv, value memv) +{ + CAMLparam2 (domv, memv); + virDomainPtr dom = Domain_val (domv); + unsigned long mem = Int64_val (memv); + int r; + + NONBLOCKING (r = virDomainSetMaxMemory (dom, mem)); + CHECK_ERROR (r == -1, "virDomainSetMaxMemory"); + + CAMLreturn (Val_unit); +} + +CAMLprim value +ocaml_libvirt_domain_set_memory (value domv, value memv) +{ + CAMLparam2 (domv, memv); + virDomainPtr dom = Domain_val (domv); + unsigned long mem = Int64_val (memv); + int r; + + NONBLOCKING (r = virDomainSetMemory (dom, mem)); + CHECK_ERROR (r == -1, "virDomainSetMemory"); + + CAMLreturn (Val_unit); +} + +CAMLprim value +ocaml_libvirt_domain_get_info (value domv) +{ + CAMLparam1 (domv); + CAMLlocal2 (rv, v); + virDomainPtr dom = Domain_val (domv); + virDomainInfo info; + int r; + + NONBLOCKING (r = virDomainGetInfo (dom, &info)); + CHECK_ERROR (r == -1, "virDomainGetInfo"); + + rv = caml_alloc (5, 0); + Store_field (rv, 0, Val_int (info.state)); // These flags are compatible. + v = caml_copy_int64 (info.maxMem); Store_field (rv, 1, v); + v = caml_copy_int64 (info.memory); Store_field (rv, 2, v); + Store_field (rv, 3, Val_int (info.nrVirtCpu)); + v = caml_copy_int64 (info.cpuTime); Store_field (rv, 4, v); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_domain_get_scheduler_type (value domv) +{ + CAMLparam1 (domv); + CAMLlocal2 (rv, strv); + virDomainPtr dom = Domain_val (domv); + char *r; + int nparams; + + NONBLOCKING (r = virDomainGetSchedulerType (dom, &nparams)); + CHECK_ERROR (!r, "virDomainGetSchedulerType"); + + rv = caml_alloc_tuple (2); + strv = caml_copy_string (r); Store_field (rv, 0, strv); + free (r); + Store_field (rv, 1, nparams); + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_domain_get_scheduler_parameters (value domv, value nparamsv) +{ + CAMLparam2 (domv, nparamsv); + CAMLlocal4 (rv, v, v2, v3); + virDomainPtr dom = Domain_val (domv); + int nparams = Int_val (nparamsv); + virSchedParameterPtr params; + int r, i; + + params = malloc (sizeof (*params) * nparams); + if (params == NULL) + caml_raise_out_of_memory (); + + NONBLOCKING (r = virDomainGetSchedulerParameters (dom, params, &nparams)); + CHECK_ERROR_CLEANUP (r == -1, free (params), "virDomainGetSchedulerParameters"); + + rv = caml_alloc (nparams, 0); + for (i = 0; i < nparams; ++i) { + v = caml_alloc_tuple (2); Store_field (rv, i, v); + v2 = caml_copy_string (params[i].field); Store_field (v, 0, v2); + switch (params[i].type) { + case VIR_DOMAIN_SCHED_FIELD_INT: + v2 = caml_alloc (1, 0); + v3 = caml_copy_int32 (params[i].value.i); Store_field (v2, 0, v3); + break; + case VIR_DOMAIN_SCHED_FIELD_UINT: + v2 = caml_alloc (1, 1); + v3 = caml_copy_int32 (params[i].value.ui); Store_field (v2, 0, v3); + break; + case VIR_DOMAIN_SCHED_FIELD_LLONG: + v2 = caml_alloc (1, 2); + v3 = caml_copy_int64 (params[i].value.l); Store_field (v2, 0, v3); + break; + case VIR_DOMAIN_SCHED_FIELD_ULLONG: + v2 = caml_alloc (1, 3); + v3 = caml_copy_int64 (params[i].value.ul); Store_field (v2, 0, v3); + break; + case VIR_DOMAIN_SCHED_FIELD_DOUBLE: + v2 = caml_alloc (1, 4); + v3 = caml_copy_double (params[i].value.d); Store_field (v2, 0, v3); + break; + case VIR_DOMAIN_SCHED_FIELD_BOOLEAN: + v2 = caml_alloc (1, 5); + Store_field (v2, 0, Val_int (params[i].value.b)); + break; + default: + caml_failwith ((char *)__FUNCTION__); + } + Store_field (v, 1, v2); + } + free (params); + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_domain_set_scheduler_parameters (value domv, value paramsv) +{ + CAMLparam2 (domv, paramsv); + CAMLlocal1 (v); + virDomainPtr dom = Domain_val (domv); + int nparams = Wosize_val (paramsv); + virSchedParameterPtr params; + int r, i; + char *name; + + params = malloc (sizeof (*params) * nparams); + if (params == NULL) + caml_raise_out_of_memory (); + + for (i = 0; i < nparams; ++i) { + v = Field (paramsv, i); /* Points to the two-element tuple. */ + name = String_val (Field (v, 0)); + strncpy (params[i].field, name, VIR_DOMAIN_SCHED_FIELD_LENGTH); + params[i].field[VIR_DOMAIN_SCHED_FIELD_LENGTH-1] = '\0'; + v = Field (v, 1); /* Points to the sched_param_value block. */ + switch (Tag_val (v)) { + case 0: + params[i].type = VIR_DOMAIN_SCHED_FIELD_INT; + params[i].value.i = Int32_val (Field (v, 0)); + break; + case 1: + params[i].type = VIR_DOMAIN_SCHED_FIELD_UINT; + params[i].value.ui = Int32_val (Field (v, 0)); + break; + case 2: + params[i].type = VIR_DOMAIN_SCHED_FIELD_LLONG; + params[i].value.l = Int64_val (Field (v, 0)); + break; + case 3: + params[i].type = VIR_DOMAIN_SCHED_FIELD_ULLONG; + params[i].value.ul = Int64_val (Field (v, 0)); + break; + case 4: + params[i].type = VIR_DOMAIN_SCHED_FIELD_DOUBLE; + params[i].value.d = Double_val (Field (v, 0)); + break; + case 5: + params[i].type = VIR_DOMAIN_SCHED_FIELD_BOOLEAN; + params[i].value.b = Int_val (Field (v, 0)); + break; + default: + caml_failwith ((char *)__FUNCTION__); + } + } + + NONBLOCKING (r = virDomainSetSchedulerParameters (dom, params, nparams)); + free (params); + CHECK_ERROR (r == -1, "virDomainSetSchedulerParameters"); + + CAMLreturn (Val_unit); +} + +CAMLprim value +ocaml_libvirt_domain_set_vcpus (value domv, value nvcpusv) +{ + CAMLparam2 (domv, nvcpusv); + virDomainPtr dom = Domain_val (domv); + int r, nvcpus = Int_val (nvcpusv); + + NONBLOCKING (r = virDomainSetVcpus (dom, nvcpus)); + CHECK_ERROR (r == -1, "virDomainSetVcpus"); + + CAMLreturn (Val_unit); +} + +CAMLprim value +ocaml_libvirt_domain_pin_vcpu (value domv, value vcpuv, value cpumapv) +{ + CAMLparam3 (domv, vcpuv, cpumapv); + virDomainPtr dom = Domain_val (domv); + int maplen = caml_string_length (cpumapv); + unsigned char *cpumap = (unsigned char *) String_val (cpumapv); + int vcpu = Int_val (vcpuv); + int r; + + NONBLOCKING (r = virDomainPinVcpu (dom, vcpu, cpumap, maplen)); + CHECK_ERROR (r == -1, "virDomainPinVcpu"); + + CAMLreturn (Val_unit); +} + +CAMLprim value +ocaml_libvirt_domain_get_vcpus (value domv, value maxinfov, value maplenv) +{ + CAMLparam3 (domv, maxinfov, maplenv); + CAMLlocal5 (rv, infov, strv, v, v2); + virDomainPtr dom = Domain_val (domv); + int maxinfo = Int_val (maxinfov); + int maplen = Int_val (maplenv); + virVcpuInfoPtr info; + unsigned char *cpumaps; + int r, i; + + info = calloc (maxinfo, sizeof (*info)); + if (info == NULL) + caml_raise_out_of_memory (); + cpumaps = calloc (maxinfo * maplen, sizeof (*cpumaps)); + if (cpumaps == NULL) { + free (info); + caml_raise_out_of_memory (); + } + + NONBLOCKING (r = virDomainGetVcpus (dom, info, maxinfo, cpumaps, maplen)); + CHECK_ERROR_CLEANUP (r == -1, free (info); free (cpumaps), "virDomainPinVcpu"); + + /* Copy the virVcpuInfo structures. */ + infov = caml_alloc (maxinfo, 0); + for (i = 0; i < maxinfo; ++i) { + v2 = caml_alloc (4, 0); Store_field (infov, i, v2); + Store_field (v2, 0, Val_int (info[i].number)); + Store_field (v2, 1, Val_int (info[i].state)); + v = caml_copy_int64 (info[i].cpuTime); Store_field (v2, 2, v); + Store_field (v2, 3, Val_int (info[i].cpu)); + } + + /* Copy the bitmap. */ + strv = caml_alloc_string (maxinfo * maplen); + memcpy (String_val (strv), cpumaps, maxinfo * maplen); + + /* Allocate the tuple and return it. */ + rv = caml_alloc_tuple (3); + Store_field (rv, 0, Val_int (r)); /* number of CPUs. */ + Store_field (rv, 1, infov); + Store_field (rv, 2, strv); + + free (info); + free (cpumaps); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_domain_get_cpu_stats (value domv) +{ + CAMLparam1 (domv); + CAMLlocal5 (cpustats, param_head, param_node, typed_param, typed_param_value); + CAMLlocal1 (v); + virDomainPtr dom = Domain_val (domv); + virTypedParameterPtr params; + int r, cpu, ncpus, nparams, i, j, pos; + int nr_pcpus; + + /* get number of pcpus */ + NONBLOCKING (nr_pcpus = virDomainGetCPUStats(dom, NULL, 0, 0, 0, 0)); + CHECK_ERROR (nr_pcpus < 0, "virDomainGetCPUStats"); + + /* get percpu information */ + NONBLOCKING (nparams = virDomainGetCPUStats(dom, NULL, 0, 0, 1, 0)); + CHECK_ERROR (nparams < 0, "virDomainGetCPUStats"); + + if ((params = malloc(sizeof(*params) * nparams * 128)) == NULL) + caml_failwith ("virDomainGetCPUStats: malloc"); + + cpustats = caml_alloc (nr_pcpus, 0); /* cpustats: array of params(list of typed_param) */ + cpu = 0; + while (cpu < nr_pcpus) { + ncpus = nr_pcpus - cpu > 128 ? 128 : nr_pcpus - cpu; + + NONBLOCKING (r = virDomainGetCPUStats(dom, params, nparams, cpu, ncpus, 0)); + CHECK_ERROR (r < 0, "virDomainGetCPUStats"); + + for (i = 0; i < ncpus; i++) { + /* list of typed_param: single linked list of param_nodes */ + param_head = Val_emptylist; /* param_head: the head param_node of list of typed_param */ + + if (params[i * nparams].type == 0) { + Store_field(cpustats, cpu + i, param_head); + continue; + } + + for (j = r - 1; j >= 0; j--) { + pos = i * nparams + j; + if (params[pos].type == 0) + continue; + + param_node = caml_alloc(2, 0); /* param_node: typed_param, next param_node */ + Store_field(param_node, 1, param_head); + param_head = param_node; + + typed_param = caml_alloc(2, 0); /* typed_param: field name(string), typed_param_value */ + Store_field(param_node, 0, typed_param); + Store_field(typed_param, 0, caml_copy_string(params[pos].field)); + + /* typed_param_value: value with the corresponding type tag */ + switch(params[pos].type) { + case VIR_TYPED_PARAM_INT: + typed_param_value = caml_alloc (1, 0); + v = caml_copy_int32 (params[pos].value.i); + break; + case VIR_TYPED_PARAM_UINT: + typed_param_value = caml_alloc (1, 1); + v = caml_copy_int32 (params[pos].value.ui); + break; + case VIR_TYPED_PARAM_LLONG: + typed_param_value = caml_alloc (1, 2); + v = caml_copy_int64 (params[pos].value.l); + break; + case VIR_TYPED_PARAM_ULLONG: + typed_param_value = caml_alloc (1, 3); + v = caml_copy_int64 (params[pos].value.ul); + break; + case VIR_TYPED_PARAM_DOUBLE: + typed_param_value = caml_alloc (1, 4); + v = caml_copy_double (params[pos].value.d); + break; + case VIR_TYPED_PARAM_BOOLEAN: + typed_param_value = caml_alloc (1, 5); + v = Val_bool (params[pos].value.b); + break; + case VIR_TYPED_PARAM_STRING: + typed_param_value = caml_alloc (1, 6); + v = caml_copy_string (params[pos].value.s); + free (params[pos].value.s); + break; + default: + /* XXX Memory leak on this path, if there are more + * VIR_TYPED_PARAM_STRING past this point in the array. + */ + free (params); + caml_failwith ("virDomainGetCPUStats: " + "unknown parameter type returned"); + } + Store_field (typed_param_value, 0, v); + Store_field (typed_param, 1, typed_param_value); + } + Store_field (cpustats, cpu + i, param_head); + } + cpu += ncpus; + } + free(params); + CAMLreturn (cpustats); +} + +value +ocaml_libvirt_domain_get_all_domain_stats (value connv, + value statsv, value flagsv) +{ + CAMLparam3 (connv, statsv, flagsv); + CAMLlocal5 (rv, dsv, tpv, v, v1); + CAMLlocal1 (v2); + virConnectPtr conn = Connect_val (connv); + virDomainStatsRecordPtr *rstats; + unsigned int stats = 0, flags = 0; + int i, j, r; + unsigned char uuid[VIR_UUID_BUFLEN]; + + /* Get stats and flags. */ + for (; statsv != Val_int (0); statsv = Field (statsv, 1)) { + v = Field (statsv, 0); + if (v == Val_int (0)) + stats |= VIR_DOMAIN_STATS_STATE; + else if (v == Val_int (1)) + stats |= VIR_DOMAIN_STATS_CPU_TOTAL; + else if (v == Val_int (2)) + stats |= VIR_DOMAIN_STATS_BALLOON; + else if (v == Val_int (3)) + stats |= VIR_DOMAIN_STATS_VCPU; + else if (v == Val_int (4)) + stats |= VIR_DOMAIN_STATS_INTERFACE; + else if (v == Val_int (5)) + stats |= VIR_DOMAIN_STATS_BLOCK; + else if (v == Val_int (6)) + stats |= VIR_DOMAIN_STATS_PERF; + } + for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1)) { + v = Field (flagsv, 0); + if (v == Val_int (0)) + flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_ACTIVE; + else if (v == Val_int (1)) + flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_INACTIVE; + else if (v == Val_int (2)) + flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_OTHER; + else if (v == Val_int (3)) + flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_PAUSED; + else if (v == Val_int (4)) + flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_PERSISTENT; + else if (v == Val_int (5)) + flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_RUNNING; + else if (v == Val_int (6)) + flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_SHUTOFF; + else if (v == Val_int (7)) + flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_TRANSIENT; + else if (v == Val_int (8)) + flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_BACKING; + else if (v == Val_int (9)) + flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_ENFORCE_STATS; + } + + NONBLOCKING (r = virConnectGetAllDomainStats (conn, stats, &rstats, flags)); + CHECK_ERROR (r == -1, "virConnectGetAllDomainStats"); + + rv = caml_alloc (r, 0); /* domain_stats_record array. */ + for (i = 0; i < r; ++i) { + dsv = caml_alloc (2, 0); /* domain_stats_record */ + + /* Libvirt returns something superficially resembling a + * virDomainPtr, but it's not a real virDomainPtr object + * (eg. dom->id == -1, and its refcount is wrong). The only thing + * we can safely get from it is the UUID. + */ + v = caml_alloc_string (VIR_UUID_BUFLEN); + virDomainGetUUID (rstats[i]->dom, uuid); + memcpy (String_val (v), uuid, VIR_UUID_BUFLEN); + Store_field (dsv, 0, v); + + tpv = caml_alloc (rstats[i]->nparams, 0); /* typed_param array */ + for (j = 0; j < rstats[i]->nparams; ++j) { + v2 = caml_alloc (2, 0); /* typed_param: field name, value */ + Store_field (v2, 0, caml_copy_string (rstats[i]->params[j].field)); + + switch (rstats[i]->params[j].type) { + case VIR_TYPED_PARAM_INT: + v1 = caml_alloc (1, 0); + v = caml_copy_int32 (rstats[i]->params[j].value.i); + break; + case VIR_TYPED_PARAM_UINT: + v1 = caml_alloc (1, 1); + v = caml_copy_int32 (rstats[i]->params[j].value.ui); + break; + case VIR_TYPED_PARAM_LLONG: + v1 = caml_alloc (1, 2); + v = caml_copy_int64 (rstats[i]->params[j].value.l); + break; + case VIR_TYPED_PARAM_ULLONG: + v1 = caml_alloc (1, 3); + v = caml_copy_int64 (rstats[i]->params[j].value.ul); + break; + case VIR_TYPED_PARAM_DOUBLE: + v1 = caml_alloc (1, 4); + v = caml_copy_double (rstats[i]->params[j].value.d); + break; + case VIR_TYPED_PARAM_BOOLEAN: + v1 = caml_alloc (1, 5); + v = Val_bool (rstats[i]->params[j].value.b); + break; + case VIR_TYPED_PARAM_STRING: + v1 = caml_alloc (1, 6); + v = caml_copy_string (rstats[i]->params[j].value.s); + break; + default: + virDomainStatsRecordListFree (rstats); + caml_failwith ("virConnectGetAllDomainStats: " + "unknown parameter type returned"); + } + Store_field (v1, 0, v); + + Store_field (v2, 1, v1); + Store_field (tpv, j, v2); + } + + Store_field (dsv, 1, tpv); + Store_field (rv, i, dsv); + } + + virDomainStatsRecordListFree (rstats); + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_domain_migrate_native (value domv, value dconnv, value flagsv, value optdnamev, value opturiv, value optbandwidthv, value unitv) +{ + CAMLparam5 (domv, dconnv, flagsv, optdnamev, opturiv); + CAMLxparam2 (optbandwidthv, unitv); + CAMLlocal2 (flagv, rv); + virDomainPtr dom = Domain_val (domv); + virConnectPtr dconn = Connect_val (dconnv); + int flags = 0; + const char *dname = Optstring_val (optdnamev); + const char *uri = Optstring_val (opturiv); + unsigned long bandwidth; + virDomainPtr r; + + /* Iterate over the list of flags. */ + for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1)) + { + flagv = Field (flagsv, 0); + if (flagv == Val_int (0)) + flags |= VIR_MIGRATE_LIVE; + } + + if (optbandwidthv == Val_int (0)) /* None */ + bandwidth = 0; + else /* Some bandwidth */ + bandwidth = Int_val (Field (optbandwidthv, 0)); + + NONBLOCKING (r = virDomainMigrate (dom, dconn, flags, dname, uri, bandwidth)); + CHECK_ERROR (!r, "virDomainMigrate"); + + rv = Val_domain (r, dconnv); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_domain_migrate_bytecode (value *argv, int argn) +{ + return ocaml_libvirt_domain_migrate_native (argv[0], argv[1], argv[2], + argv[3], argv[4], argv[5], + argv[6]); +} + +CAMLprim value +ocaml_libvirt_domain_block_stats (value domv, value pathv) +{ + CAMLparam2 (domv, pathv); + CAMLlocal2 (rv,v); + virDomainPtr dom = Domain_val (domv); + char *path = String_val (pathv); + struct _virDomainBlockStats stats; + int r; + + NONBLOCKING (r = virDomainBlockStats (dom, path, &stats, sizeof stats)); + CHECK_ERROR (r == -1, "virDomainBlockStats"); + + rv = caml_alloc (5, 0); + v = caml_copy_int64 (stats.rd_req); Store_field (rv, 0, v); + v = caml_copy_int64 (stats.rd_bytes); Store_field (rv, 1, v); + v = caml_copy_int64 (stats.wr_req); Store_field (rv, 2, v); + v = caml_copy_int64 (stats.wr_bytes); Store_field (rv, 3, v); + v = caml_copy_int64 (stats.errs); Store_field (rv, 4, v); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_domain_interface_stats (value domv, value pathv) +{ + CAMLparam2 (domv, pathv); + CAMLlocal2 (rv,v); + virDomainPtr dom = Domain_val (domv); + char *path = String_val (pathv); + struct _virDomainInterfaceStats stats; + int r; + + NONBLOCKING (r = virDomainInterfaceStats (dom, path, &stats, sizeof stats)); + CHECK_ERROR (r == -1, "virDomainInterfaceStats"); + + rv = caml_alloc (8, 0); + v = caml_copy_int64 (stats.rx_bytes); Store_field (rv, 0, v); + v = caml_copy_int64 (stats.rx_packets); Store_field (rv, 1, v); + v = caml_copy_int64 (stats.rx_errs); Store_field (rv, 2, v); + v = caml_copy_int64 (stats.rx_drop); Store_field (rv, 3, v); + v = caml_copy_int64 (stats.tx_bytes); Store_field (rv, 4, v); + v = caml_copy_int64 (stats.tx_packets); Store_field (rv, 5, v); + v = caml_copy_int64 (stats.tx_errs); Store_field (rv, 6, v); + v = caml_copy_int64 (stats.tx_drop); Store_field (rv, 7, v); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_domain_block_peek_native (value domv, value pathv, value offsetv, value sizev, value bufferv, value boffv) +{ + CAMLparam5 (domv, pathv, offsetv, sizev, bufferv); + CAMLxparam1 (boffv); + virDomainPtr dom = Domain_val (domv); + const char *path = String_val (pathv); + unsigned long long offset = Int64_val (offsetv); + size_t size = Int_val (sizev); + char *buffer = String_val (bufferv); + int boff = Int_val (boffv); + int r; + + /* Check that the return buffer is big enough. */ + if (caml_string_length (bufferv) < boff + size) + caml_failwith ("virDomainBlockPeek: return buffer too short"); + + /* NB. not NONBLOCKING because buffer might move (XXX) */ + r = virDomainBlockPeek (dom, path, offset, size, buffer+boff, 0); + CHECK_ERROR (r == -1, "virDomainBlockPeek"); + + CAMLreturn (Val_unit); +} + +CAMLprim value +ocaml_libvirt_domain_block_peek_bytecode (value *argv, int argn) +{ + return ocaml_libvirt_domain_block_peek_native (argv[0], argv[1], argv[2], + argv[3], argv[4], argv[5]); +} + +CAMLprim value +ocaml_libvirt_domain_memory_peek_native (value domv, value flagsv, value offsetv, value sizev, value bufferv, value boffv) +{ + CAMLparam5 (domv, flagsv, offsetv, sizev, bufferv); + CAMLxparam1 (boffv); + CAMLlocal1 (flagv); + virDomainPtr dom = Domain_val (domv); + int flags = 0; + unsigned long long offset = Int64_val (offsetv); + size_t size = Int_val (sizev); + char *buffer = String_val (bufferv); + int boff = Int_val (boffv); + int r; + + /* Check that the return buffer is big enough. */ + if (caml_string_length (bufferv) < boff + size) + caml_failwith ("virDomainMemoryPeek: return buffer too short"); + + /* Do flags. */ + for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1)) + { + flagv = Field (flagsv, 0); + if (flagv == Val_int (0)) + flags |= VIR_MEMORY_VIRTUAL; + } + + /* NB. not NONBLOCKING because buffer might move (XXX) */ + r = virDomainMemoryPeek (dom, offset, size, buffer+boff, flags); + CHECK_ERROR (r == -1, "virDomainMemoryPeek"); + + CAMLreturn (Val_unit); +} + +CAMLprim value +ocaml_libvirt_domain_memory_peek_bytecode (value *argv, int argn) +{ + return ocaml_libvirt_domain_memory_peek_native (argv[0], argv[1], argv[2], + argv[3], argv[4], argv[5]); +} + +CAMLprim value +ocaml_libvirt_domain_get_xml_desc_flags (value domv, value flagsv) +{ + CAMLparam2 (domv, flagsv); + CAMLlocal2 (rv, flagv); + virDomainPtr dom = Domain_val (domv); + int flags = 0; + char *r; + + /* Do flags. */ + for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1)) + { + flagv = Field (flagsv, 0); + if (flagv == Val_int (0)) + flags |= VIR_DOMAIN_XML_SECURE; + else if (flagv == Val_int (1)) + flags |= VIR_DOMAIN_XML_INACTIVE; + else if (flagv == Val_int (2)) + flags |= VIR_DOMAIN_XML_UPDATE_CPU; + else if (flagv == Val_int (3)) + flags |= VIR_DOMAIN_XML_MIGRATABLE; + } + + NONBLOCKING (r = virDomainGetXMLDesc (dom, flags)); + CHECK_ERROR (!r, "virDomainGetXMLDesc"); + + rv = caml_copy_string (r); + free (r); + CAMLreturn (rv); +} + +/*----------------------------------------------------------------------*/ + +/* Domain events */ + +CAMLprim value +ocaml_libvirt_event_register_default_impl (value unitv) +{ + CAMLparam1 (unitv); + + /* arg is of type unit = void */ + int r; + + NONBLOCKING (r = virEventRegisterDefaultImpl ()); + /* must be called before connection, therefore we can't use CHECK_ERROR */ + if (r == -1) caml_failwith("virEventRegisterDefaultImpl"); + + CAMLreturn (Val_unit); +} + +CAMLprim value +ocaml_libvirt_event_run_default_impl (value unitv) +{ + CAMLparam1 (unitv); + + /* arg is of type unit = void */ + int r; + + NONBLOCKING (r = virEventRunDefaultImpl ()); + if (r == -1) caml_failwith("virEventRunDefaultImpl"); + + CAMLreturn (Val_unit); +} + +/* We register a single C callback function for every distinct + callback signature. We encode the signature itself in the function + name and also in the name of the assocated OCaml callback + e.g.: + a C function called + i_i64_s_callback(virConnectPtr conn, + virDomainPtr dom, + int x, + long y, + char *z, + void *opaque) + would correspond to an OCaml callback + Libvirt.i_i64_s_callback : + int64 -> [`R] Domain.t -> int -> int64 -> string option -> unit + where the initial int64 is a unique ID used by the OCaml to + dispatch to the specific OCaml closure and stored by libvirt + as the "opaque" data. */ + +/* Every one of the callbacks starts with a DOMAIN_CALLBACK_BEGIN(NAME) + where NAME is the string name of the OCaml callback registered + in libvirt.ml. */ +#define DOMAIN_CALLBACK_BEGIN(NAME) \ + value connv, domv, callback_id, result; \ + connv = domv = callback_id = result = Val_int(0); \ + static value *callback = NULL; \ + caml_leave_blocking_section(); \ + if (callback == NULL) \ + callback = caml_named_value(NAME); \ + if (callback == NULL) \ + abort(); /* C code out of sync with OCaml code */ \ + if ((virDomainRef(dom) == -1) || (virConnectRef(conn) == -1)) \ + abort(); /* should never happen in practice? */ \ + \ + Begin_roots4(connv, domv, callback_id, result); \ + connv = Val_connect(conn); \ + domv = Val_domain(dom, connv); \ + callback_id = caml_copy_int64(*(long *)opaque); + +/* Every one of the callbacks ends with a CALLBACK_END */ +#define DOMAIN_CALLBACK_END \ + (void) caml_callback3(*callback, callback_id, domv, result); \ + End_roots(); \ + caml_enter_blocking_section(); + + +static void +i_i_callback(virConnectPtr conn, + virDomainPtr dom, + int x, + int y, + void * opaque) +{ + DOMAIN_CALLBACK_BEGIN("Libvirt.i_i_callback") + result = caml_alloc_tuple(2); + Store_field(result, 0, Val_int(x)); + Store_field(result, 1, Val_int(y)); + DOMAIN_CALLBACK_END +} + +static void +u_callback(virConnectPtr conn, + virDomainPtr dom, + void *opaque) +{ + DOMAIN_CALLBACK_BEGIN("Libvirt.u_callback") + result = Val_int(0); /* () */ + DOMAIN_CALLBACK_END +} + +static void +i64_callback(virConnectPtr conn, + virDomainPtr dom, + long long int64, + void *opaque) +{ + DOMAIN_CALLBACK_BEGIN("Libvirt.i64_callback") + result = caml_copy_int64(int64); + DOMAIN_CALLBACK_END +} + +static void +i_callback(virConnectPtr conn, + virDomainPtr dom, + int x, + void *opaque) +{ + DOMAIN_CALLBACK_BEGIN("Libvirt.i_callback") + result = Val_int(x); + DOMAIN_CALLBACK_END +} + +static void +s_i_callback(virConnectPtr conn, + virDomainPtr dom, + char *x, + int y, + void * opaque) +{ + DOMAIN_CALLBACK_BEGIN("Libvirt.s_i_callback") + result = caml_alloc_tuple(2); + Store_field(result, 0, + Val_opt(x, (Val_ptr_t) caml_copy_string)); + Store_field(result, 1, Val_int(y)); + DOMAIN_CALLBACK_END +} + +static void +s_i_i_callback(virConnectPtr conn, + virDomainPtr dom, + char *x, + int y, + int z, + void * opaque) +{ + DOMAIN_CALLBACK_BEGIN("Libvirt.s_i_i_callback") + result = caml_alloc_tuple(3); + Store_field(result, 0, + Val_opt(x, (Val_ptr_t) caml_copy_string)); + Store_field(result, 1, Val_int(y)); + Store_field(result, 2, Val_int(z)); + DOMAIN_CALLBACK_END +} + +static void +s_s_i_callback(virConnectPtr conn, + virDomainPtr dom, + char *x, + char *y, + int z, + void *opaque) +{ + DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_i_callback") + result = caml_alloc_tuple(3); + Store_field(result, 0, + Val_opt(x, (Val_ptr_t) caml_copy_string)); + Store_field(result, 1, + Val_opt(y, (Val_ptr_t) caml_copy_string)); + Store_field(result, 2, Val_int(z)); + DOMAIN_CALLBACK_END +} + +static void +s_s_i_s_callback(virConnectPtr conn, + virDomainPtr dom, + char *x, + char *y, + int z, + char *a, + void *opaque) +{ + DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_i_s_callback") + result = caml_alloc_tuple(4); + Store_field(result, 0, + Val_opt(x, (Val_ptr_t) caml_copy_string)); + Store_field(result, 1, + Val_opt(y, (Val_ptr_t) caml_copy_string)); + Store_field(result, 2, Val_int(z)); + Store_field(result, 3, + Val_opt(a, (Val_ptr_t) caml_copy_string)); + DOMAIN_CALLBACK_END +} + +static void +s_s_s_i_callback(virConnectPtr conn, + virDomainPtr dom, + char * x, + char * y, + char * z, + int a, + void * opaque) +{ + DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_s_i_callback") + result = caml_alloc_tuple(4); + Store_field(result, 0, + Val_opt(x, (Val_ptr_t) caml_copy_string)); + Store_field(result, 1, + Val_opt(y, (Val_ptr_t) caml_copy_string)); + Store_field(result, 2, + Val_opt(z, (Val_ptr_t) caml_copy_string)); + Store_field(result, 3, Val_int(a)); + DOMAIN_CALLBACK_END +} + +static value +Val_event_graphics_address(virDomainEventGraphicsAddressPtr x) +{ + CAMLparam0 (); + CAMLlocal1(result); + result = caml_alloc_tuple(3); + Store_field(result, 0, Val_int(x->family)); + Store_field(result, 1, + Val_opt((void *) x->node, (Val_ptr_t) caml_copy_string)); + Store_field(result, 2, + Val_opt((void *) x->service, (Val_ptr_t) caml_copy_string)); + CAMLreturn(result); +} + +static value +Val_event_graphics_subject_identity(virDomainEventGraphicsSubjectIdentityPtr x) +{ + CAMLparam0 (); + CAMLlocal1(result); + result = caml_alloc_tuple(2); + Store_field(result, 0, + Val_opt((void *) x->type, (Val_ptr_t) caml_copy_string)); + Store_field(result, 1, + Val_opt((void *) x->name, (Val_ptr_t) caml_copy_string)); + CAMLreturn(result); + +} + +static value +Val_event_graphics_subject(virDomainEventGraphicsSubjectPtr x) +{ + CAMLparam0 (); + CAMLlocal1(result); + int i; + result = caml_alloc_tuple(x->nidentity); + for (i = 0; i < x->nidentity; i++ ) + Store_field(result, i, + Val_event_graphics_subject_identity(x->identities + i)); + CAMLreturn(result); +} + +static void +i_ga_ga_s_gs_callback(virConnectPtr conn, + virDomainPtr dom, + int i1, + virDomainEventGraphicsAddressPtr ga1, + virDomainEventGraphicsAddressPtr ga2, + char *s1, + virDomainEventGraphicsSubjectPtr gs1, + void * opaque) +{ + DOMAIN_CALLBACK_BEGIN("Libvirt.i_ga_ga_s_gs_callback") + result = caml_alloc_tuple(5); + Store_field(result, 0, Val_int(i1)); + Store_field(result, 1, Val_event_graphics_address(ga1)); + Store_field(result, 2, Val_event_graphics_address(ga2)); + Store_field(result, 3, + Val_opt(s1, (Val_ptr_t) caml_copy_string)); + Store_field(result, 4, Val_event_graphics_subject(gs1)); + DOMAIN_CALLBACK_END +} + +static void +timeout_callback(int timer, void *opaque) +{ + value callback_id, result; + callback_id = result = Val_int(0); + static value *callback = NULL; + caml_leave_blocking_section(); + if (callback == NULL) + callback = caml_named_value("Libvirt.timeout_callback"); + if (callback == NULL) + abort(); /* C code out of sync with OCaml code */ + + Begin_roots2(callback_id, result); + callback_id = caml_copy_int64(*(long *)opaque); + + (void)caml_callback_exn(*callback, callback_id); + End_roots(); + caml_enter_blocking_section(); +} + +CAMLprim value +ocaml_libvirt_event_add_timeout (value connv, value ms, value callback_id) +{ + CAMLparam3 (connv, ms, callback_id); + void *opaque; + virFreeCallback freecb = free; + virEventTimeoutCallback cb = timeout_callback; + + int r; + + /* Store the int64 callback_id as the opaque data so the OCaml + callback can demultiplex to the correct OCaml handler. */ + if ((opaque = malloc(sizeof(long))) == NULL) + caml_failwith ("virEventAddTimeout: malloc"); + *((long*)opaque) = Int64_val(callback_id); + NONBLOCKING(r = virEventAddTimeout(Int_val(ms), cb, opaque, freecb)); + CHECK_ERROR(r == -1, "virEventAddTimeout"); + + CAMLreturn(Val_int(r)); +} + +CAMLprim value +ocaml_libvirt_event_remove_timeout (value connv, value timer_id) +{ + CAMLparam2 (connv, timer_id); + int r; + + NONBLOCKING(r = virEventRemoveTimeout(Int_val(timer_id))); + CHECK_ERROR(r == -1, "virEventRemoveTimeout"); + + CAMLreturn(Val_int(r)); +} + +CAMLprim value +ocaml_libvirt_connect_domain_event_register_any(value connv, value domv, value callback, value callback_id) +{ + CAMLparam4(connv, domv, callback, callback_id); + + virConnectPtr conn = Connect_val (connv); + virDomainPtr dom = NULL; + int eventID = Tag_val(callback); + + virConnectDomainEventGenericCallback cb; + void *opaque; + virFreeCallback freecb = free; + int r; + + if (domv != Val_int(0)) + dom = Domain_val (Field(domv, 0)); + + switch (eventID){ + case VIR_DOMAIN_EVENT_ID_LIFECYCLE: + cb = VIR_DOMAIN_EVENT_CALLBACK(i_i_callback); + break; + case VIR_DOMAIN_EVENT_ID_REBOOT: + cb = VIR_DOMAIN_EVENT_CALLBACK(u_callback); + break; + case VIR_DOMAIN_EVENT_ID_RTC_CHANGE: + cb = VIR_DOMAIN_EVENT_CALLBACK(i64_callback); + break; + case VIR_DOMAIN_EVENT_ID_WATCHDOG: + cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback); + break; + case VIR_DOMAIN_EVENT_ID_IO_ERROR: + cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_i_callback); + break; + case VIR_DOMAIN_EVENT_ID_GRAPHICS: + cb = VIR_DOMAIN_EVENT_CALLBACK(i_ga_ga_s_gs_callback); + break; + case VIR_DOMAIN_EVENT_ID_IO_ERROR_REASON: + cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_i_s_callback); + break; + case VIR_DOMAIN_EVENT_ID_CONTROL_ERROR: + cb = VIR_DOMAIN_EVENT_CALLBACK(u_callback); + break; + case VIR_DOMAIN_EVENT_ID_BLOCK_JOB: + cb = VIR_DOMAIN_EVENT_CALLBACK(s_i_i_callback); + break; + case VIR_DOMAIN_EVENT_ID_DISK_CHANGE: + cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_s_i_callback); + break; + case VIR_DOMAIN_EVENT_ID_TRAY_CHANGE: + cb = VIR_DOMAIN_EVENT_CALLBACK(s_i_callback); + break; + case VIR_DOMAIN_EVENT_ID_PMWAKEUP: + cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback); + break; + case VIR_DOMAIN_EVENT_ID_PMSUSPEND: + cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback); + break; + case VIR_DOMAIN_EVENT_ID_BALLOON_CHANGE: + cb = VIR_DOMAIN_EVENT_CALLBACK(i64_callback); + break; + case VIR_DOMAIN_EVENT_ID_PMSUSPEND_DISK: + cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback); + break; + default: + caml_failwith("vifConnectDomainEventRegisterAny: unimplemented eventID"); + } + + /* Store the int64 callback_id as the opaque data so the OCaml + callback can demultiplex to the correct OCaml handler. */ + if ((opaque = malloc(sizeof(long))) == NULL) + caml_failwith ("virConnectDomainEventRegisterAny: malloc"); + *((long*)opaque) = Int64_val(callback_id); + NONBLOCKING(r = virConnectDomainEventRegisterAny(conn, dom, eventID, cb, opaque, freecb)); + CHECK_ERROR(r == -1, "virConnectDomainEventRegisterAny"); + + CAMLreturn(Val_int(r)); +} + +CAMLprim value +ocaml_libvirt_storage_pool_get_info (value poolv) +{ + CAMLparam1 (poolv); + CAMLlocal2 (rv, v); + virStoragePoolPtr pool = Pool_val (poolv); + virStoragePoolInfo info; + int r; + + NONBLOCKING (r = virStoragePoolGetInfo (pool, &info)); + CHECK_ERROR (r == -1, "virStoragePoolGetInfo"); + + rv = caml_alloc (4, 0); + Store_field (rv, 0, Val_int (info.state)); + v = caml_copy_int64 (info.capacity); Store_field (rv, 1, v); + v = caml_copy_int64 (info.allocation); Store_field (rv, 2, v); + v = caml_copy_int64 (info.available); Store_field (rv, 3, v); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_storage_vol_get_info (value volv) +{ + CAMLparam1 (volv); + CAMLlocal2 (rv, v); + virStorageVolPtr vol = Volume_val (volv); + virStorageVolInfo info; + int r; + + NONBLOCKING (r = virStorageVolGetInfo (vol, &info)); + CHECK_ERROR (r == -1, "virStorageVolGetInfo"); + + rv = caml_alloc (3, 0); + Store_field (rv, 0, Val_int (info.type)); + v = caml_copy_int64 (info.capacity); Store_field (rv, 1, v); + v = caml_copy_int64 (info.allocation); Store_field (rv, 2, v); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_secret_lookup_by_usage (value connv, value usagetypev, value usageidv) +{ + CAMLparam3 (connv, usagetypev, usageidv); + CAMLlocal1 (rv); + virConnectPtr conn = Connect_val (connv); + int usageType = Int_val (usagetypev); + const char *usageID = String_val (usageidv); + virSecretPtr r; + + NONBLOCKING (r = virSecretLookupByUsage (conn, usageType, usageID)); + CHECK_ERROR (!r, "virSecretLookupByUsage"); + + rv = Val_secret (r, connv); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_secret_set_value (value secv, value vv) +{ + CAMLparam2 (secv, vv); + virSecretPtr sec = Secret_val (secv); + const unsigned char *secval = (unsigned char *) String_val (vv); + const size_t size = caml_string_length (vv); + int r; + + NONBLOCKING (r = virSecretSetValue (sec, secval, size, 0)); + CHECK_ERROR (r == -1, "virSecretSetValue"); + + CAMLreturn (Val_unit); +} + +CAMLprim value +ocaml_libvirt_secret_get_value (value secv) +{ + CAMLparam1 (secv); + CAMLlocal1 (rv); + virSecretPtr sec = Secret_val (secv); + unsigned char *secval; + size_t size = 0; + + NONBLOCKING (secval = virSecretGetValue (sec, &size, 0)); + CHECK_ERROR (secval == NULL, "virSecretGetValue"); + + rv = caml_alloc_string (size); + memcpy (String_val (rv), secval, size); + free (secval); + + CAMLreturn (rv); +} + +/*----------------------------------------------------------------------*/ + +CAMLprim value +ocaml_libvirt_virterror_get_last_error (value unitv) +{ + CAMLparam1 (unitv); + CAMLlocal1 (rv); + virErrorPtr err = virGetLastError (); + + rv = Val_opt (err, (Val_ptr_t) Val_virterror); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_virterror_get_last_conn_error (value connv) +{ + CAMLparam1 (connv); + CAMLlocal1 (rv); + virConnectPtr conn = Connect_val (connv); + + rv = Val_opt (conn, (Val_ptr_t) Val_connect); + + CAMLreturn (rv); +} + +CAMLprim value +ocaml_libvirt_virterror_reset_last_error (value unitv) +{ + CAMLparam1 (unitv); + virResetLastError (); + CAMLreturn (Val_unit); +} + +CAMLprim value +ocaml_libvirt_virterror_reset_last_conn_error (value connv) +{ + CAMLparam1 (connv); + virConnectPtr conn = Connect_val (connv); + virConnResetLastError (conn); + CAMLreturn (Val_unit); +} + +/*----------------------------------------------------------------------*/ + +static void +ignore_errors (void *user_data, virErrorPtr error) +{ + /* do nothing */ +} + +/* Initialise the library. */ +CAMLprim value +ocaml_libvirt_init (value unit) +{ + CAMLparam1 (unit); + + virSetErrorFunc (NULL, ignore_errors); + virInitialize (); + + CAMLreturn (Val_unit); +} diff --git a/common/mllibvirt/libvirt_c_prologue.c b/common/mllibvirt/libvirt_c_prologue.c new file mode 100644 index 000000000..8533618c6 --- /dev/null +++ b/common/mllibvirt/libvirt_c_prologue.c @@ -0,0 +1,134 @@ +/* OCaml bindings for libvirt. + * (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + * https://libvirt.org/ + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2 of the License, or (at your option) any later version, + * with the OCaml linking exception described in ../COPYING.LIB. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +/* Please read libvirt/README file. */ + +static const char *Optstring_val (value strv); +typedef value (*Val_ptr_t) (void *); +static value Val_opt (void *ptr, Val_ptr_t Val_ptr); +typedef value (*Val_const_ptr_t) (const void *); +static value Val_opt_const (const void *ptr, Val_const_ptr_t Val_ptr); +/*static value option_default (value option, value deflt);*/ +static void _raise_virterror (const char *fn) Noreturn; +static value Val_virterror (virErrorPtr err); +static int _list_length (value listv); +static value Val_virconnectcredential (const virConnectCredentialPtr cred); + +/* Use this around synchronous libvirt API calls to release the OCaml + * lock, allowing other threads to run simultaneously. 'code' must not + * perform any caml_* calls, run any OCaml code, or raise any exception. + * https://web.archive.org/web/20030521020915/http://caml.inria.fr/archives/... + */ +#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

Store the Libvirt.Connect.t object as instance variable, so it can be used also outside of prepare_targets. Use a private method to access it, so there is no need to directly use the Lazy object. --- v2v/output_libvirt.ml | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml index 30857c572..e62e43bb8 100644 --- a/v2v/output_libvirt.ml +++ b/v2v/output_libvirt.ml @@ -59,11 +59,16 @@ let target_features_of_capabilities_doc doc arch = List.map Xml.node_name features ) -class output_libvirt oc output_pool = object +class output_libvirt oc output_pool = +object (self) inherit output val mutable capabilities_doc = None val mutable pool_name = None + val lazy_conn = lazy (Libvirt.Connect.connect ?name:oc ()) + + method private conn : Libvirt.rw Libvirt.Connect.t = + Lazy.force lazy_conn method as_options = match oc with @@ -71,13 +76,10 @@ class output_libvirt oc output_pool = object | Some uri -> sprintf "-o libvirt -oc %s -os %s" uri output_pool method prepare_targets source overlays _ _ _ _ = - (* Open the connection to libvirt. *) - let conn = Libvirt.Connect.connect ?name:oc () in - (* Get the capabilities from libvirt. *) let xml = try - Libvirt.Connect.get_capabilities conn + Libvirt.Connect.get_capabilities self#conn with Libvirt.Virterror { message } -> error (f_"cannot get libvirt hypervisor capabilities: %s") @@ -96,7 +98,7 @@ class output_libvirt oc output_pool = object capabilities_doc <- Some doc; (* Does the domain already exist on the target? (RHBZ#889082) *) - if Libvirt_utils.domain_exists conn source.s_name then ( + if Libvirt_utils.domain_exists self#conn source.s_name then ( if source.s_hypervisor = Physical then (* virt-p2v user *) error (f_"a libvirt domain called ‘%s’ already exists on the target.\n\nIf using virt-p2v, select a different ‘Name’ in the ‘Target properties’. Or delete the existing domain on the target using the ‘virsh undefine’ command.") source.s_name @@ -109,7 +111,7 @@ class output_libvirt oc output_pool = object * and dump out its XML. *) let xml = - let pool = Libvirt_utils.get_pool conn output_pool in + let pool = Libvirt_utils.get_pool self#conn output_pool in Libvirt.Pool.get_xml_desc (Libvirt.Pool.const pool) in let doc = Xml.parse_memory xml in let xpathctx = Xml.xpath_new_context doc in -- 2.20.1

Use the embedded copy. --- Makefile.am | 2 -- v2v/test-harness/Makefile.am | 5 ++--- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/Makefile.am b/Makefile.am index 259e5cd93..b5f33f62b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -174,10 +174,8 @@ SUBDIRS += sparsify SUBDIRS += sysprep if HAVE_LIBVIRT SUBDIRS += v2v -if HAVE_OCAML_PKG_LIBVIRT SUBDIRS += v2v/test-harness endif -endif if HAVE_FUSE SUBDIRS += dib endif diff --git a/v2v/test-harness/Makefile.am b/v2v/test-harness/Makefile.am index cebee9914..2c53f538f 100644 --- a/v2v/test-harness/Makefile.am +++ b/v2v/test-harness/Makefile.am @@ -31,13 +31,12 @@ SOURCES_ML = \ v2v_test_harness.ml if HAVE_OCAML -if HAVE_OCAML_PKG_LIBVIRT # -I $(top_builddir)/lib/.libs is a hack which forces corresponding -L # option to be passed to gcc, so we don't try linking against an # installed copy of libguestfs. OCAMLPACKAGES = \ - -package str,unix,libvirt \ + -package str,unix \ -I $(top_builddir)/common/utils/.libs \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ @@ -45,6 +44,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/common/mlxml \ -I $(top_builddir)/common/mltools \ + -I $(top_builddir)/common/mllibvirt \ -I $(top_builddir)/v2v OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR) -ccopt '$(CFLAGS)' @@ -130,7 +130,6 @@ stamp-virt-v2v-test-harness.pod: virt-v2v-test-harness.pod $(top_builddir)/ocaml-dep.sh -I .. $^ -include .depend -endif endif .PHONY: docs -- 2.20.1