While there are input modes that do not use libvirt, making libvirt mandatory for virt-v2v slightly simplifies the code now, and allow for further improvements/integration with libvirt later on. --- Makefile.am | 2 ++ v2v/Makefile.am | 20 ++++++-------------- v2v/libvirt_utils-c.c | 22 ---------------------- v2v/v2v.ml | 12 +++--------- 4 files changed, 11 insertions(+), 45 deletions(-) diff --git a/Makefile.am b/Makefile.am index 0067d7b7b..cf9ca512e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -169,10 +169,12 @@ SUBDIRS += get-kernel SUBDIRS += resize SUBDIRS += sparsify SUBDIRS += sysprep +if HAVE_LIBVIRT SUBDIRS += v2v if HAVE_OCAML_PKG_LIBVIRT SUBDIRS += v2v/test-harness endif +endif if HAVE_FUSE SUBDIRS += dib endif diff --git a/v2v/Makefile.am b/v2v/Makefile.am index 39511022e..5999a6b50 100644 --- a/v2v/Makefile.am +++ b/v2v/Makefile.am @@ -423,6 +423,7 @@ stamp-virt-v2v-support.pod: virt-v2v-support.pod TESTS_ENVIRONMENT = $(top_builddir)/run --test TESTS = \ + test-v2v-copy-to-local.sh \ test-v2v-docs.sh \ test-v2v-python-syntax.sh \ test-v2v-i-ova-bad-sha1.sh \ @@ -442,29 +443,19 @@ TESTS = \ test-v2v-o-vdsm-oo-query.sh \ test-v2v-bad-networks-and-bridges.sh -if HAVE_LIBVIRT -TESTS += \ - test-v2v-copy-to-local.sh -endif - if HAVE_OCAML_PKG_OUNIT TESTS += v2v_unit_tests var_expander_tests endif if ENABLE_APPLIANCE -TESTS += \ - test-v2v-i-ova.sh \ - test-v2v-i-disk.sh \ - test-v2v-machine-readable.sh \ - test-v2v-virtio-win-iso.sh \ - test-v2v-windows-conversion.sh - -if HAVE_LIBVIRT TESTS += \ test-v2v-cdrom.sh \ test-v2v-floppy.sh \ + test-v2v-i-disk.sh \ + test-v2v-i-ova.sh \ test-v2v-in-place.sh \ test-v2v-mac.sh \ + test-v2v-machine-readable.sh \ test-v2v-networks-and-bridges.sh \ test-v2v-no-copy.sh \ test-v2v-o-glance.sh \ @@ -481,9 +472,10 @@ TESTS += \ test-v2v-print-estimate.sh \ test-v2v-print-source.sh \ test-v2v-sound.sh \ + test-v2v-virtio-win-iso.sh \ + test-v2v-windows-conversion.sh $(SLOW_TESTS) \ $(ROOT_TESTS) -endif endif ENABLE_APPLIANCE # The VMDK file is used for some -i ova tests. diff --git a/v2v/libvirt_utils-c.c b/v2v/libvirt_utils-c.c index 0e365eac7..5ca0d5363 100644 --- a/v2v/libvirt_utils-c.c +++ b/v2v/libvirt_utils-c.c @@ -35,18 +35,14 @@ #include <caml/memory.h> #include <caml/mlvalues.h> -#ifdef HAVE_LIBVIRT #include <libvirt/libvirt.h> #include <libvirt/virterror.h> -#endif #include "guestfs.h" #include "guestfs-utils.h" #pragma GCC diagnostic ignored "-Wmissing-prototypes" -#ifdef HAVE_LIBVIRT - #define ERROR_MESSAGE_LEN 512 static void @@ -519,21 +515,3 @@ v2v_libvirt_get_version (value unitv) CAMLreturn (rv); } - -#else /* !HAVE_LIBVIRT */ - -#define NO_LIBVIRT(proto) \ - proto __attribute__((noreturn)); \ - proto \ - { \ - caml_invalid_argument ("virt-v2v was compiled without libvirt support"); \ - } - -NO_LIBVIRT (value v2v_dumpxml (value connv, value domv)) -NO_LIBVIRT (value v2v_pool_dumpxml (value connv, value poolv)) -NO_LIBVIRT (value v2v_vol_dumpxml (value connv, value poolnamev, value volnamev)) -NO_LIBVIRT (value v2v_capabilities (value connv, value unitv)) -NO_LIBVIRT (value v2v_domain_exists (value connv, value domnamev)) -NO_LIBVIRT (value v2v_libvirt_get_version (value unitv)) - -#endif /* !HAVE_LIBVIRT */ diff --git a/v2v/v2v.ml b/v2v/v2v.ml index 277d8f2c7..c056aa787 100644 --- a/v2v/v2v.ml +++ b/v2v/v2v.ml @@ -59,16 +59,10 @@ let rec main () = prog Guestfs_config.package_name Guestfs_config.package_version_full Guestfs_config.host_cpu; - (* Print the libvirt version if debugging. Note that if - * we're configured --without-libvirt, then this will throw - * an exception, but some conversions should still be possible, - * hence the try block. - *) + (* Print the libvirt version if debugging. *) if verbose () then ( - try - let major, minor, release = Libvirt_utils.libvirt_get_version () in - debug "libvirt version: %d.%d.%d" major minor release - with _ -> () + let major, minor, release = Libvirt_utils.libvirt_get_version () in + debug "libvirt version: %d.%d.%d" major minor release ); (* Perform pre-flight checks on the input and output objects. *) -- 2.20.1

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

Currently virt-v2v has few custom C-based functions for libvirt operations, which are limited in what they do, and there is a lot of duplicated code. Instead, switch to ocaml-libvirt for all the libvirt interaction currently done by the Libvirt_utils module. This has few advantages: - each input & output module now opens a libvirt connection only once, only when needed - no need to pass URIs and passwords around, if not needed - a wider range of libvirt APIs can now be used, with no need to create bindings manually The hierarchy of input_libvirt* classes is changed to take a Lazy object with the libvirt connection, accessing it through a "proctected" method: this way, the connection is opened only at the first access. Also, the Libvirt_utils module now is just helpers around the Libvirt module, to centralize error handling, and few common operations. --- docs/C_SOURCE_FILES | 1 - po/POTFILES | 1 - v2v/Makefile.am | 6 +- v2v/copy_to_local.ml | 7 +- v2v/input_libvirt.ml | 20 +- v2v/input_libvirt_other.ml | 27 +- v2v/input_libvirt_other.mli | 5 +- v2v/input_libvirt_vcenter_https.ml | 13 +- v2v/input_libvirt_vcenter_https.mli | 2 +- v2v/input_libvirt_vddk.ml | 15 +- v2v/input_libvirt_vddk.mli | 4 +- v2v/input_libvirt_xen_ssh.ml | 13 +- v2v/input_libvirt_xen_ssh.mli | 2 +- v2v/libvirt_utils-c.c | 517 ---------------------------- v2v/libvirt_utils.ml | 95 ++++- v2v/libvirt_utils.mli | 51 ++- v2v/output_libvirt.ml | 17 +- v2v/parse_libvirt_xml.ml | 23 +- v2v/parse_libvirt_xml.mli | 11 +- 19 files changed, 207 insertions(+), 623 deletions(-) delete mode 100644 v2v/libvirt_utils-c.c diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES index 7f1c60b30..519acedd5 100644 --- a/docs/C_SOURCE_FILES +++ b/docs/C_SOURCE_FILES @@ -414,6 +414,5 @@ utils/boot-analysis/boot-analysis.h utils/boot-benchmark/boot-benchmark.c utils/qemu-boot/qemu-boot.c utils/qemu-speed-test/qemu-speed-test.c -v2v/libvirt_utils-c.c v2v/qemuopts-c.c v2v/test-harness/dummy.c diff --git a/po/POTFILES b/po/POTFILES index 79f4b8c56..8d603162f 100644 --- a/po/POTFILES +++ b/po/POTFILES @@ -471,6 +471,5 @@ utils/boot-benchmark/boot-benchmark.c utils/max-disks/max-disks.pl utils/qemu-boot/qemu-boot.c utils/qemu-speed-test/qemu-speed-test.c -v2v/libvirt_utils-c.c v2v/qemuopts-c.c v2v/test-harness/dummy.c diff --git a/v2v/Makefile.am b/v2v/Makefile.am index 5999a6b50..13948c24e 100644 --- a/v2v/Makefile.am +++ b/v2v/Makefile.am @@ -163,7 +163,6 @@ SOURCES_ML = \ v2v.ml SOURCES_C = \ - libvirt_utils-c.c \ qemuopts-c.c # These files are generated and contain *.py embedded as an OCaml string. @@ -212,6 +211,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/common/mlpcre \ -I $(top_builddir)/common/mlxml \ -I $(top_builddir)/common/mltools \ + -I $(top_builddir)/common/mllibvirt \ -I $(top_builddir)/customize if HAVE_OCAML_PKG_GETTEXT OCAMLPACKAGES += -package gettext-stub @@ -242,6 +242,7 @@ OCAMLLINKFLAGS = \ mlxml.$(MLARCHIVE) \ mlcutils.$(MLARCHIVE) \ mltools.$(MLARCHIVE) \ + mllibvirt.$(MLARCHIVE) \ $(LINK_CUSTOM_OCAMLC_ONLY) virt_v2v_DEPENDENCIES = $(OBJECTS) $(top_srcdir)/ocaml-link.sh @@ -251,7 +252,7 @@ virt_v2v_LINK = \ $(OBJECTS) -o $@ virt_v2v_copy_to_local_SOURCES = \ - libvirt_utils-c.c + dummy.c virt_v2v_copy_to_local_CPPFLAGS = \ -I. \ -I$(top_builddir) \ @@ -284,6 +285,7 @@ virt_v2v_copy_to_local_DEPENDENCIES = \ ../common/mlpcre/mlpcre.$(MLARCHIVE) \ ../common/mlutils/mlcutils.$(MLARCHIVE) \ ../common/mltools/mltools.$(MLARCHIVE) \ + ../common/mllibvirt/mllibvirt.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh virt_v2v_copy_to_local_LINK = \ $(top_srcdir)/ocaml-link.sh -cclib '$(OCAMLCLIBS)' -- \ diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml index 408cbdebc..e841b44c5 100644 --- a/v2v/copy_to_local.ml +++ b/v2v/copy_to_local.ml @@ -125,7 +125,12 @@ read the man page virt-v2v-copy-to-local(1). (* Get the remote libvirt XML. *) message (f_"Fetching the remote libvirt XML metadata ..."); - let xml = Libvirt_utils.dumpxml ?password_file ~conn:input_conn guest_name in + let xml = + let auth = Libvirt_utils.auth_for_password_file ?password_file () in + let conn = Libvirt.Connect.connect_auth ~name:input_conn auth in + let dom = Libvirt_utils.get_domain conn guest_name in + (* Use XmlSecure to get passwords (RHBZ#1174123). *) + Libvirt.Domain.get_xml_desc_flags dom [Libvirt.Domain.XmlSecure] in debug "libvirt XML from remote server:\n%s" xml; diff --git a/v2v/input_libvirt.ml b/v2v/input_libvirt.ml index 0e4afa157..3418e9f28 100644 --- a/v2v/input_libvirt.ml +++ b/v2v/input_libvirt.ml @@ -28,9 +28,17 @@ open Utils (* Choose the right subclass based on the URI. *) let input_libvirt input_conn input_password input_transport guest = + (* Create a lazy object to open the connection to libvirt only when + * needed. + *) + let lazy_conn = + lazy ( + let auth = Libvirt_utils.auth_for_password_file ?password_file:input_password () in + Libvirt.Connect.connect_auth ?name:input_conn auth + ) in match input_conn with | None -> - Input_libvirt_other.input_libvirt_other input_conn input_password guest + Input_libvirt_other.input_libvirt_other lazy_conn guest | Some orig_uri -> let { Xml.uri_server = server; uri_scheme = scheme } as parsed_uri = @@ -45,22 +53,22 @@ let input_libvirt input_conn input_password input_transport guest = | Some _, None, _ (* No scheme? *) | Some _, Some "", _ -> - Input_libvirt_other.input_libvirt_other input_conn input_password guest + Input_libvirt_other.input_libvirt_other lazy_conn guest (* vCenter over https. *) | Some server, Some ("esx"|"gsx"|"vpx"), None -> Input_libvirt_vcenter_https.input_libvirt_vcenter_https - input_conn input_password parsed_uri server guest + lazy_conn input_password parsed_uri server guest (* vCenter or ESXi using nbdkit vddk plugin *) | Some server, Some ("esx"|"gsx"|"vpx"), Some (`VDDK vddk_options) -> - Input_libvirt_vddk.input_libvirt_vddk input_conn input_password + Input_libvirt_vddk.input_libvirt_vddk lazy_conn input_conn input_password vddk_options parsed_uri guest (* Xen over SSH *) | Some server, Some "xen+ssh", _ -> Input_libvirt_xen_ssh.input_libvirt_xen_ssh - input_conn input_password parsed_uri server guest + lazy_conn parsed_uri server guest (* Old virt-v2v also supported qemu+ssh://. However I am * deliberately not supporting this in new virt-v2v. Don't @@ -71,6 +79,6 @@ let input_libvirt input_conn input_password input_transport guest = | Some _, Some _, _ -> warning (f_"no support for remote libvirt connections to '-ic %s'. The conversion may fail when it tries to read the source disks.") orig_uri; - Input_libvirt_other.input_libvirt_other input_conn input_password guest + Input_libvirt_other.input_libvirt_other lazy_conn guest let () = Modules_list.register_input_module "libvirt" diff --git a/v2v/input_libvirt_other.ml b/v2v/input_libvirt_other.ml index dc69d64e5..aff1a872b 100644 --- a/v2v/input_libvirt_other.ml +++ b/v2v/input_libvirt_other.ml @@ -40,35 +40,28 @@ let error_if_libvirt_does_not_support_json_backingfile () = error (f_"because of libvirt bug https://bugzilla.redhat.com/1134878 you must EITHER upgrade to libvirt >= 2.1.0 OR set this environment variable:\n\nexport LIBGUESTFS_BACKEND=direct\n\nand then rerun the virt-v2v command.") (* Superclass. *) -class virtual input_libvirt input_conn (input_password : string option) guest = -object +class virtual input_libvirt lazy_conn guest = +object (self) inherit input method as_options = - sprintf "-i libvirt%s %s" - (match input_conn with - | None -> "" - | Some uri -> " -ic " ^ uri) - guest + sprintf "-i libvirt -ic %s %s" (Libvirt.Connect.get_uri self#conn) guest + + method private conn : Libvirt.rw Libvirt.Connect.t = + Lazy.force lazy_conn end (* Subclass specialized for handling anything that's *not* VMware vCenter * or Xen. *) -class input_libvirt_other input_conn input_password guest = -object - inherit input_libvirt input_conn input_password guest +class input_libvirt_other lazy_conn guest = +object (self) + inherit input_libvirt lazy_conn guest method source () = debug "input_libvirt_other: source ()"; - (* Get the libvirt XML. This also checks (as a side-effect) - * that the domain is not running. (RHBZ#1138586) - *) - let xml = Libvirt_utils.dumpxml ?password_file:input_password - ?conn:input_conn guest in - - let source, disks = parse_libvirt_xml ?conn:input_conn xml in + let source, disks, _ = parse_libvirt_domain self#conn guest in let disks = List.map (fun { p_source_disk = disk } -> disk) disks in { source with s_disks = disks } end diff --git a/v2v/input_libvirt_other.mli b/v2v/input_libvirt_other.mli index e6671a76b..10f574281 100644 --- a/v2v/input_libvirt_other.mli +++ b/v2v/input_libvirt_other.mli @@ -20,11 +20,12 @@ val error_if_libvirt_does_not_support_json_backingfile : unit -> unit -class virtual input_libvirt : string option -> string option -> string -> object +class virtual input_libvirt : Libvirt.rw Libvirt.Connect.t Lazy.t -> string -> object method precheck : unit -> unit method as_options : string method virtual source : unit -> Types.source method adjust_overlay_parameters : Types.overlay -> unit + method private conn : Libvirt.rw Libvirt.Connect.t end -val input_libvirt_other : string option -> string option -> string -> Types.input +val input_libvirt_other : Libvirt.rw Libvirt.Connect.t Lazy.t -> string -> Types.input diff --git a/v2v/input_libvirt_vcenter_https.ml b/v2v/input_libvirt_vcenter_https.ml index 96f009771..adc05f8c1 100644 --- a/v2v/input_libvirt_vcenter_https.ml +++ b/v2v/input_libvirt_vcenter_https.ml @@ -36,9 +36,9 @@ let readahead_for_copying = Some (64 * 1024 * 1024) (* Subclass specialized for handling VMware vCenter over https. *) class input_libvirt_vcenter_https - input_conn input_password parsed_uri server guest = -object - inherit input_libvirt input_conn input_password guest + lazy_conn input_password parsed_uri server guest = +object (self) + inherit input_libvirt lazy_conn guest val saved_source_paths = Hashtbl.create 13 val mutable dcPath = "" @@ -61,12 +61,7 @@ object unsetenv "ALL_PROXY"; unsetenv "NO_PROXY"; - (* Get the libvirt XML. This also checks (as a side-effect) - * that the domain is not running. (RHBZ#1138586) - *) - let xml = Libvirt_utils.dumpxml ?password_file:input_password - ?conn:input_conn guest in - let source, disks = parse_libvirt_xml ?conn:input_conn xml in + let source, disks, xml = parse_libvirt_domain self#conn guest in (* Find the <vmware:datacenterpath> element from the XML. This * was added in libvirt >= 1.2.20. diff --git a/v2v/input_libvirt_vcenter_https.mli b/v2v/input_libvirt_vcenter_https.mli index 966cc674c..c59a34a71 100644 --- a/v2v/input_libvirt_vcenter_https.mli +++ b/v2v/input_libvirt_vcenter_https.mli @@ -18,4 +18,4 @@ (** [-i libvirt] when the source is VMware vCenter *) -val input_libvirt_vcenter_https : string option -> string option -> Xml.uri -> string -> string -> Types.input +val input_libvirt_vcenter_https : Libvirt.rw Libvirt.Connect.t Lazy.t -> string option -> Xml.uri -> string -> string -> Types.input diff --git a/v2v/input_libvirt_vddk.ml b/v2v/input_libvirt_vddk.ml index 97c7cb532..827c4dbf4 100644 --- a/v2v/input_libvirt_vddk.ml +++ b/v2v/input_libvirt_vddk.ml @@ -93,8 +93,8 @@ let parse_input_options options = options (* Subclass specialized for handling VMware via nbdkit vddk plugin. *) -class input_libvirt_vddk input_conn input_password vddk_options parsed_uri - guest = +class input_libvirt_vddk lazy_conn input_conn input_password vddk_options + parsed_uri guest = (* The VDDK path. *) let libdir = try Some (List.assoc "libdir" vddk_options) @@ -198,8 +198,8 @@ See also the virt-v2v-input-vmware(1) manual.") libNN error (f_"nbdkit was compiled without SELinux support. You will have to recompile nbdkit with libselinux-devel installed, or else set SELinux to Permissive mode while doing the conversion.") in -object - inherit input_libvirt input_conn input_password guest as super +object (self) + inherit input_libvirt lazy_conn guest as super method precheck () = error_unless_vddk_libdir (); @@ -219,12 +219,7 @@ object pt_options method source () = - (* Get the libvirt XML. This also checks (as a side-effect) - * that the domain is not running. (RHBZ#1138586) - *) - let xml = Libvirt_utils.dumpxml ?password_file:input_password - ?conn:input_conn guest in - let source, disks = parse_libvirt_xml ?conn:input_conn xml in + let source, disks, xml = parse_libvirt_domain self#conn guest in (* Find the <vmware:moref> element from the XML. This was added * in libvirt >= 3.7 and is required. diff --git a/v2v/input_libvirt_vddk.mli b/v2v/input_libvirt_vddk.mli index d321677d8..66d5f6f15 100644 --- a/v2v/input_libvirt_vddk.mli +++ b/v2v/input_libvirt_vddk.mli @@ -25,7 +25,7 @@ val print_input_options : unit -> unit val parse_input_options : (string * string) list -> vddk_options (** Print and parse vddk -io options. *) -val input_libvirt_vddk : string option -> string option -> vddk_options -> Xml.uri -> string -> Types.input -(** [input_libvirt_vddk input_conn input_password vddk_options parsed_uri guest] +val input_libvirt_vddk : Libvirt.rw Libvirt.Connect.t Lazy.t -> string option -> string option -> vddk_options -> Xml.uri -> string -> Types.input +(** [input_libvirt_vddk lazy_conn vddk_options parsed_uri guest] creates and returns a {!Types.input} object specialized for reading the guest disks using the nbdkit vddk plugin. *) diff --git a/v2v/input_libvirt_xen_ssh.ml b/v2v/input_libvirt_xen_ssh.ml index 6b77db029..f1d7d3bed 100644 --- a/v2v/input_libvirt_xen_ssh.ml +++ b/v2v/input_libvirt_xen_ssh.ml @@ -30,9 +30,9 @@ open Input_libvirt_other open Printf (* Subclass specialized for handling Xen over SSH. *) -class input_libvirt_xen_ssh input_conn input_password parsed_uri server guest = -object - inherit input_libvirt input_conn input_password guest +class input_libvirt_xen_ssh lazy_conn parsed_uri server guest = +object (self) + inherit input_libvirt lazy_conn guest method precheck () = if backend_is_libvirt () then @@ -43,12 +43,7 @@ object method source () = debug "input_libvirt_xen_ssh: source: server %s" server; - (* Get the libvirt XML. This also checks (as a side-effect) - * that the domain is not running. (RHBZ#1138586) - *) - let xml = Libvirt_utils.dumpxml ?password_file:input_password - ?conn:input_conn guest in - let source, disks = parse_libvirt_xml ?conn:input_conn xml in + let source, disks, _ = parse_libvirt_domain self#conn guest in (* Map the <source/> filename (which is relative to the remote * Xen server) to an ssh URI. This is a JSON URI looking something diff --git a/v2v/input_libvirt_xen_ssh.mli b/v2v/input_libvirt_xen_ssh.mli index 73c2645a1..6649b9883 100644 --- a/v2v/input_libvirt_xen_ssh.mli +++ b/v2v/input_libvirt_xen_ssh.mli @@ -18,4 +18,4 @@ (** [-i libvirt] when the source is Xen *) -val input_libvirt_xen_ssh : string option -> string option -> Xml.uri -> string -> string -> Types.input +val input_libvirt_xen_ssh : Libvirt.rw Libvirt.Connect.t Lazy.t -> Xml.uri -> string -> string -> Types.input diff --git a/v2v/libvirt_utils-c.c b/v2v/libvirt_utils-c.c deleted file mode 100644 index 5ca0d5363..000000000 --- a/v2v/libvirt_utils-c.c +++ /dev/null @@ -1,517 +0,0 @@ -/* virt-v2v - * Copyright (C) 2009-2019 Red Hat Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - */ - -/** - * This module implements various C<virsh>-like commands, but with - * non-broken authentication handling. - */ - -#include <config.h> - -#include <stdio.h> -#include <stdlib.h> -#include <stdarg.h> -#include <string.h> -#include <errno.h> -#include <libintl.h> - -#include <caml/alloc.h> -#include <caml/fail.h> -#include <caml/memory.h> -#include <caml/mlvalues.h> - -#include <libvirt/libvirt.h> -#include <libvirt/virterror.h> - -#include "guestfs.h" -#include "guestfs-utils.h" - -#pragma GCC diagnostic ignored "-Wmissing-prototypes" - -#define ERROR_MESSAGE_LEN 512 - -static void -ignore_errors (void *ignore, virErrorPtr ignore2) -{ - /* empty */ -} - -/* Get the remote domain state (running, etc.). Use virDomainGetState - * which is most efficient, but if it's not implemented, fall back to - * virDomainGetInfo. See equivalent code in virsh. - */ -static int -get_dom_state (virDomainPtr dom) -{ - int state, reason; - virErrorPtr err; - virDomainInfo info; - - if (virDomainGetState (dom, &state, &reason, 0) == 0) - return state; - - err = virGetLastError (); - if (!err || err->code != VIR_ERR_NO_SUPPORT) - return -1; - - if (virDomainGetInfo (dom, &info) == 0) - return info.state; - - return -1; -} - -/* See lib/libvirt-auth.c for why we need this. */ -static int -libvirt_auth_default_wrapper (virConnectCredentialPtr cred, - unsigned int ncred, - void *passwordvp) -{ - const char *password = passwordvp; - unsigned int i; - - if (password) { - /* If --password-file was specified on the command line, and the - * libvirt handler is asking for a password, return that. - */ - for (i = 0; i < ncred; ++i) { - if (cred[i].type == VIR_CRED_PASSPHRASE) { - cred[i].result = strdup (password); - cred[i].resultlen = strlen (password); - } - else { - cred[i].result = NULL; - cred[i].resultlen = 0; - } - } - return 0; - } - else { - /* No --password-file so call the default handler. */ - return virConnectAuthPtrDefault->cb (cred, ncred, - virConnectAuthPtrDefault->cbdata); - } -} - -virStoragePoolPtr -connect_and_load_pool (value connv, value poolnamev) -{ - CAMLparam2 (connv, poolnamev); - const char *conn_uri = NULL; - const char *poolname; - /* We have to assemble the error on the stack because a dynamic - * string couldn't be freed. - */ - char errmsg[ERROR_MESSAGE_LEN]; - virErrorPtr err; - virConnectPtr conn; - virStoragePoolPtr pool; - - if (connv != Val_int (0)) - conn_uri = String_val (Field (connv, 0)); /* Some conn */ - - /* We have to call the default authentication handler, not least - * since it handles all the PolicyKit crap. However it also makes - * coding this simpler. - */ - conn = virConnectOpenAuth (conn_uri, virConnectAuthPtrDefault, - VIR_CONNECT_RO); - if (conn == NULL) { - if (conn_uri) - snprintf (errmsg, sizeof errmsg, - _("cannot open libvirt connection ‘%s’"), conn_uri); - else - snprintf (errmsg, sizeof errmsg, _("cannot open libvirt connection")); - caml_invalid_argument (errmsg); - } - - /* Suppress default behaviour of printing errors to stderr. Note - * you can't set this to NULL to ignore errors; setting it to NULL - * restores the default error handler ... - */ - virConnSetErrorFunc (conn, NULL, ignore_errors); - - /* Look up the pool. */ - poolname = String_val (poolnamev); - - pool = virStoragePoolLookupByUUIDString (conn, poolname); - - if (!pool) - pool = virStoragePoolLookupByName (conn, poolname); - - if (!pool) { - err = virGetLastError (); - snprintf (errmsg, sizeof errmsg, - _("cannot find libvirt pool ‘%s’: %s\n\nUse ‘virsh pool-list --all’ to list all available pools, and ‘virsh pool-dumpxml <pool>’ to display details about a particular pool.\n\nTo set the pool which virt-v2v uses, add the ‘-os <pool>’ option."), - poolname, err->message); - virConnectClose (conn); - caml_invalid_argument (errmsg); - } - - CAMLreturnT (virStoragePoolPtr, pool); -} - -value -v2v_dumpxml (value passwordv, value connv, value domnamev) -{ - CAMLparam3 (passwordv, connv, domnamev); - CAMLlocal1 (retv); - const char *password = NULL; - const char *conn_uri = NULL; - const char *domname; - virConnectAuth authdata; - /* We have to assemble the error on the stack because a dynamic - * string couldn't be freed. - */ - char errmsg[ERROR_MESSAGE_LEN]; - virErrorPtr err; - virConnectPtr conn; - virDomainPtr dom; - int is_test_uri = 0; - char *xml; - - if (passwordv != Val_int (0)) - password = String_val (Field (passwordv, 0)); /* Some password */ - - if (connv != Val_int (0)) { - conn_uri = String_val (Field (connv, 0)); /* Some conn */ - is_test_uri = STRPREFIX (conn_uri, "test:"); - } - - /* Set up authentication wrapper. */ - authdata = *virConnectAuthPtrDefault; - authdata.cb = libvirt_auth_default_wrapper; - authdata.cbdata = (void *) password; - - /* Note this cannot be a read-only connection since we need to use - * the VIR_DOMAIN_XML_SECURE flag below. - */ - conn = virConnectOpenAuth (conn_uri, &authdata, 0); - if (conn == NULL) { - if (conn_uri) - snprintf (errmsg, sizeof errmsg, - _("cannot open libvirt connection ‘%s’"), conn_uri); - else - snprintf (errmsg, sizeof errmsg, _("cannot open libvirt connection")); - caml_invalid_argument (errmsg); - } - - /* Suppress default behaviour of printing errors to stderr. Note - * you can't set this to NULL to ignore errors; setting it to NULL - * restores the default error handler ... - */ - virConnSetErrorFunc (conn, NULL, ignore_errors); - - /* Look up the domain. */ - domname = String_val (domnamev); - - dom = virDomainLookupByUUIDString (conn, domname); - - if (!dom) - dom = virDomainLookupByName (conn, domname); - - if (!dom) { - err = virGetLastError (); - snprintf (errmsg, sizeof errmsg, - _("cannot find libvirt domain ‘%s’: %s"), domname, err->message); - virConnectClose (conn); - caml_invalid_argument (errmsg); - } - - /* As a side-effect we check that the domain is shut down. Of course - * this is only appropriate for virt-v2v. (RHBZ#1138586) - */ - if (!is_test_uri) { - const int state = get_dom_state (dom); - - if (state == VIR_DOMAIN_RUNNING || - state == VIR_DOMAIN_BLOCKED || - state == VIR_DOMAIN_PAUSED) { - snprintf (errmsg, sizeof errmsg, - _("libvirt domain ‘%s’ is running or paused. It must be shut down in order to perform virt-v2v conversion"), - domname); - virDomainFree (dom); - virConnectClose (conn); - caml_invalid_argument (errmsg); - } - } - - /* Use VIR_DOMAIN_XML_SECURE to get passwords (RHBZ#1174123). */ - xml = virDomainGetXMLDesc (dom, VIR_DOMAIN_XML_SECURE); - if (xml == NULL) { - err = virGetLastError (); - snprintf (errmsg, sizeof errmsg, - _("cannot fetch XML description of guest ‘%s’: %s"), - domname, err->message); - virDomainFree (dom); - virConnectClose (conn); - caml_invalid_argument (errmsg); - } - virDomainFree (dom); - virConnectClose (conn); - - retv = caml_copy_string (xml); - free (xml); - - CAMLreturn (retv); -} - -value -v2v_pool_dumpxml (value connv, value poolnamev) -{ - CAMLparam2 (connv, poolnamev); - CAMLlocal1 (retv); - /* We have to assemble the error on the stack because a dynamic - * string couldn't be freed. - */ - char errmsg[ERROR_MESSAGE_LEN]; - virErrorPtr err; - virConnectPtr conn; - virStoragePoolPtr pool; - char *xml; - - /* Look up the pool. */ - pool = connect_and_load_pool (connv, poolnamev); - conn = virStoragePoolGetConnect (pool); - - xml = virStoragePoolGetXMLDesc (pool, 0); - if (xml == NULL) { - err = virGetLastError (); - snprintf (errmsg, sizeof errmsg, - _("cannot fetch XML description of pool ‘%s’: %s"), - String_val (poolnamev), err->message); - virStoragePoolFree (pool); - virConnectClose (conn); - caml_invalid_argument (errmsg); - } - virStoragePoolFree (pool); - virConnectClose (conn); - - retv = caml_copy_string (xml); - free (xml); - - CAMLreturn (retv); -} - -value -v2v_vol_dumpxml (value connv, value poolnamev, value volnamev) -{ - CAMLparam3 (connv, poolnamev, volnamev); - CAMLlocal1 (retv); - const char *volname; - /* We have to assemble the error on the stack because a dynamic - * string couldn't be freed. - */ - char errmsg[ERROR_MESSAGE_LEN]; - virErrorPtr err; - virConnectPtr conn; - virStoragePoolPtr pool; - virStorageVolPtr vol; - char *xml; - - /* Look up the pool. */ - pool = connect_and_load_pool (connv, poolnamev); - conn = virStoragePoolGetConnect (pool); - - /* Look up the volume. */ - volname = String_val (volnamev); - - vol = virStorageVolLookupByName (pool, volname); - - if (!vol) { - err = virGetLastError (); - snprintf (errmsg, sizeof errmsg, - _("cannot find libvirt volume ‘%s’: %s"), volname, err->message); - virStoragePoolFree (pool); - virConnectClose (conn); - caml_invalid_argument (errmsg); - } - - xml = virStorageVolGetXMLDesc (vol, 0); - if (xml == NULL) { - err = virGetLastError (); - snprintf (errmsg, sizeof errmsg, - _("cannot fetch XML description of volume ‘%s’: %s"), - volname, err->message); - virStorageVolFree (vol); - virStoragePoolFree (pool); - virConnectClose (conn); - caml_invalid_argument (errmsg); - } - virStorageVolFree (vol); - virStoragePoolFree (pool); - virConnectClose (conn); - - retv = caml_copy_string (xml); - free (xml); - - CAMLreturn (retv); -} - -value -v2v_capabilities (value connv, value unitv) -{ - CAMLparam2 (connv, unitv); - CAMLlocal1 (capabilitiesv); - const char *conn_uri = NULL; - char *capabilities; - /* We have to assemble the error on the stack because a dynamic - * string couldn't be freed. - */ - char errmsg[ERROR_MESSAGE_LEN]; - virErrorPtr err; - virConnectPtr conn; - - if (connv != Val_int (0)) - conn_uri = String_val (Field (connv, 0)); /* Some conn */ - - /* We have to call the default authentication handler, not least - * since it handles all the PolicyKit crap. However it also makes - * coding this simpler. - */ - conn = virConnectOpenAuth (conn_uri, virConnectAuthPtrDefault, - VIR_CONNECT_RO); - if (conn == NULL) { - if (conn_uri) - snprintf (errmsg, sizeof errmsg, - _("cannot open libvirt connection ‘%s’"), conn_uri); - else - snprintf (errmsg, sizeof errmsg, _("cannot open libvirt connection")); - caml_invalid_argument (errmsg); - } - - /* Suppress default behaviour of printing errors to stderr. Note - * you can't set this to NULL to ignore errors; setting it to NULL - * restores the default error handler ... - */ - virConnSetErrorFunc (conn, NULL, ignore_errors); - - capabilities = virConnectGetCapabilities (conn); - if (!capabilities) { - err = virGetLastError (); - snprintf (errmsg, sizeof errmsg, - _("cannot get libvirt hypervisor capabilities: %s"), - err->message); - virConnectClose (conn); - caml_invalid_argument (errmsg); - } - - capabilitiesv = caml_copy_string (capabilities); - free (capabilities); - - virConnectClose (conn); - - CAMLreturn (capabilitiesv); -} - -value -v2v_domain_exists (value connv, value domnamev) -{ - CAMLparam2 (connv, domnamev); - const char *conn_uri = NULL; - const char *domname; - /* We have to assemble the error on the stack because a dynamic - * string couldn't be freed. - */ - char errmsg[ERROR_MESSAGE_LEN]; - virErrorPtr err; - virConnectPtr conn; - virDomainPtr dom; - int domain_exists; - - if (connv != Val_int (0)) - conn_uri = String_val (Field (connv, 0)); /* Some conn */ - - /* We have to call the default authentication handler, not least - * since it handles all the PolicyKit crap. However it also makes - * coding this simpler. - */ - conn = virConnectOpenAuth (conn_uri, virConnectAuthPtrDefault, - VIR_CONNECT_RO); - if (conn == NULL) { - if (conn_uri) - snprintf (errmsg, sizeof errmsg, - _("cannot open libvirt connection ‘%s’"), conn_uri); - else - snprintf (errmsg, sizeof errmsg, _("cannot open libvirt connection")); - caml_invalid_argument (errmsg); - } - - /* Suppress default behaviour of printing errors to stderr. Note - * you can't set this to NULL to ignore errors; setting it to NULL - * restores the default error handler ... - */ - virConnSetErrorFunc (conn, NULL, ignore_errors); - - /* Look up the domain. */ - domname = String_val (domnamev); - dom = virDomainLookupByName (conn, domname); - - if (dom) { - domain_exists = 1; - virDomainFree (dom); - } - else { - err = virGetLastError (); - if (err->code == VIR_ERR_NO_DOMAIN) - domain_exists = 0; - else { - snprintf (errmsg, sizeof errmsg, - _("cannot find libvirt domain ‘%s’: %s"), - domname, err->message); - virConnectClose (conn); - caml_invalid_argument (errmsg); - } - } - - virConnectClose (conn); - - CAMLreturn (Val_bool (domain_exists)); -} - -value -v2v_libvirt_get_version (value unitv) -{ - CAMLparam1 (unitv); - CAMLlocal1 (rv); - int major, minor, release; - /* We have to assemble the error on the stack because a dynamic - * string couldn't be freed. - */ - char errmsg[ERROR_MESSAGE_LEN]; - unsigned long ver; - virErrorPtr err; - - if (virGetVersion (&ver, NULL, NULL) == -1) { - err = virGetLastError (); - snprintf (errmsg, sizeof errmsg, - _("cannot get libvirt library version: %s"), - err->message); - caml_invalid_argument (errmsg); - } - - major = ver / 1000000UL; - minor = ver / 1000UL % 1000UL; - release = ver % 1000UL; - - rv = caml_alloc (3, 0); - Store_field (rv, 0, Val_int (major)); - Store_field (rv, 1, Val_int (minor)); - Store_field (rv, 2, Val_int (release)); - - CAMLreturn (rv); -} diff --git a/v2v/libvirt_utils.ml b/v2v/libvirt_utils.ml index efb186a2c..e6d315403 100644 --- a/v2v/libvirt_utils.ml +++ b/v2v/libvirt_utils.ml @@ -17,21 +17,92 @@ *) open Std_utils +open Tools_utils +open Common_gettext.Gettext -(* This module implements various [virsh]-like commands, but with - non-broken authentication handling. *) +(* This module provides helper methods on top of the Libvirt + module. *) -external dumpxml : ?password:string -> ?conn:string -> string -> string = "v2v_dumpxml" -let dumpxml ?password_file = - let password = Option.map read_first_line_from_file password_file in - dumpxml ?password +let auth_for_password_file ?password_file () = + let auth_fn creds = + let password = Option.map read_first_line_from_file password_file in + List.map ( + function + | { Libvirt.Connect.typ = Libvirt.Connect.CredentialPassphrase } -> password + | _ -> None + ) creds + in -external pool_dumpxml : ?conn:string -> string -> string = "v2v_pool_dumpxml" -external vol_dumpxml : ?conn:string -> string -> string -> string = "v2v_vol_dumpxml" + { + Libvirt.Connect.credtype = [ Libvirt.Connect.CredentialPassphrase ]; + cb = auth_fn; + } -external capabilities : ?conn:string -> unit -> string = "v2v_capabilities" +let get_domain conn name = + let dom = + try + Libvirt.Domain.lookup_by_uuid_string conn name + with + (* No such domain. *) + | Libvirt.Virterror { code = VIR_ERR_NO_DOMAIN } + (* Invalid UUID string. *) + | Libvirt.Virterror { code = VIR_ERR_INVALID_ARG; domain = VIR_FROM_DOMAIN } -> + (try + Libvirt.Domain.lookup_by_name conn name + with + Libvirt.Virterror { code = VIR_ERR_NO_DOMAIN; message } -> + error (f_"cannot find libvirt domain ‘%s’: %s") + name (Option.default "" message) + ) in + let uri = Libvirt.Connect.get_uri conn in + (* As a side-effect we check that the domain is shut down. Of course + * this is only appropriate for virt-v2v. (RHBZ#1138586) + *) + if not (String.is_prefix uri "test:") then ( + (match (Libvirt.Domain.get_info dom).Libvirt.Domain.state with + | InfoRunning | InfoBlocked | InfoPaused -> + error (f_"libvirt domain ‘%s’ is running or paused. It must be shut down in order to perform virt-v2v conversion") + (Libvirt.Domain.get_name dom) + | InfoNoState | InfoShutdown | InfoShutoff | InfoCrashed | InfoPMSuspended -> + () + ) + ); + dom -external domain_exists : ?conn:string -> string -> bool = "v2v_domain_exists" +let get_pool conn name = + try + Libvirt.Pool.lookup_by_uuid_string conn name + with + (* No such pool. *) + | Libvirt.Virterror { code = VIR_ERR_NO_STORAGE_POOL } + (* Invalid UUID string. *) + | Libvirt.Virterror { code = VIR_ERR_INVALID_ARG; domain = VIR_FROM_STORAGE } -> + (try + Libvirt.Pool.lookup_by_name conn name + with Libvirt.Virterror { code = VIR_ERR_NO_STORAGE_POOL; message } -> + error (f_"cannot find libvirt pool ‘%s’: %s\n\nUse ‘virsh pool-list --all’ to list all available pools, and ‘virsh pool-dumpxml <pool>’ to display details about a particular pool.\n\nTo set the pool which virt-v2v uses, add the ‘-os <pool>’ option.") + name (Option.default "" message) + ) -external libvirt_get_version : unit -> int * int * int - = "v2v_libvirt_get_version" +let get_volume pool name = + try + Libvirt.Volume.lookup_by_name pool name + with + (* No such volume. *) + | Libvirt.Virterror { code = VIR_ERR_NO_STORAGE_VOL; message } -> + error (f_"cannot find libvirt volume ‘%s’: %s") + name (Option.default "" message) + +let domain_exists conn dom = + try + ignore (Libvirt.Domain.lookup_by_name conn dom); + true + with + Libvirt.Virterror { code = VIR_ERR_NO_DOMAIN } -> false + +let libvirt_get_version () = + let v, _ = Libvirt.get_version () in + let v_major = v / 1000000 in + let v_minor = (v / 1000) mod 1000 in + let v_micro = v mod 1000 in + (v_major, v_minor, v_micro) diff --git a/v2v/libvirt_utils.mli b/v2v/libvirt_utils.mli index e6ba47ae8..91b2997ee 100644 --- a/v2v/libvirt_utils.mli +++ b/v2v/libvirt_utils.mli @@ -16,38 +16,35 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -(** This module implements various [virsh]-like commands, but with - non-broken authentication handling. +(** This module provides helper methods on top of the [Libvirt] + module. *) - If you do [virsh dumpxml foo] and if the libvirt source (eg. ESX) - requires an interactive password, then virsh unhelpfully sends the - password prompt to stdout, which is the same place we would be - reading the XML from. This file works around this brokenness. *) +val auth_for_password_file : ?password_file:string -> unit -> Libvirt.Connect.auth +(** [auth_for_password_file ?password_file ()] returns a + {!Libvirt.Connect.auth} record to use when opening a new libvirt + connection with {!Libvirt.Connect.connect_auth} or + {!Libvirt.Connect.connect_auth_readonly}. The record will + authenticate using the password specified in the first line of + [?password_file], if specified. *) -val dumpxml : ?password_file:string -> ?conn:string -> string -> string -(** [dumpxml ?password_file ?conn dom] returns the libvirt XML of domain [dom]. - The optional [?conn] parameter is the libvirt connection URI. - [dom] may be a guest name or UUID. *) +val get_domain : Libvirt.rw Libvirt.Connect.t -> string -> Libvirt.rw Libvirt.Domain.t +(** [get_domain conn dom] returns the libvirt domain with the + specified [dom] name or UUID. [conn] is the libvirt + connection. *) -val pool_dumpxml : ?conn:string -> string -> string -(** [pool_dumpxml ?conn pool] returns the libvirt XML of pool [pool]. - The optional [?conn] parameter is the libvirt connection URI. - [pool] may be a pool name or UUID. *) +val get_pool : Libvirt.rw Libvirt.Connect.t -> string -> Libvirt.rw Libvirt.Pool.t +(** [get_pool conn pool] returns the libvirt pool with the + specified [pool] name or UUID. [conn] is the libvirt + connection. *) -val vol_dumpxml : ?conn:string -> string -> string -> string -(** [vol_dumpxml ?conn pool vol] returns the libvirt XML of volume [vol], - which is part of the pool [pool]. - The optional [?conn] parameter is the libvirt connection URI. - [pool] may be a pool name or UUID. *) +val get_volume : Libvirt.rw Libvirt.Pool.t -> string -> Libvirt.rw Libvirt.Volume.t +(** [get_volume pool vol] returns the libvirt volume with the + specified [vol] name or UUID, as part of the pool [pool]. *) -val capabilities : ?conn:string -> unit -> string -(** [capabilities ?conn ()] returns the libvirt capabilities XML. - The optional [?conn] parameter is the libvirt connection URI. *) - -val domain_exists : ?conn:string -> string -> bool -(** [domain_exists ?conn dom] returns a boolean indicating if the - the libvirt XML domain [dom] exists. - The optional [?conn] parameter is the libvirt connection URI. +val domain_exists : Libvirt.rw Libvirt.Connect.t -> string -> bool +(** [domain_exists conn dom] returns a boolean indicating if the + the libvirt XML domain [dom] exists. [conn] is the libvirt + connection. [dom] may be a guest name, but not a UUID. *) val libvirt_get_version : unit -> int * int * int diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml index e110897c2..30857c572 100644 --- a/v2v/output_libvirt.ml +++ b/v2v/output_libvirt.ml @@ -71,8 +71,17 @@ class output_libvirt oc output_pool = object | Some uri -> sprintf "-o libvirt -oc %s -os %s" uri output_pool method prepare_targets source overlays _ _ _ _ = + (* Open the connection to libvirt. *) + let conn = Libvirt.Connect.connect ?name:oc () in + (* Get the capabilities from libvirt. *) - let xml = Libvirt_utils.capabilities ?conn:oc () in + let xml = + try + Libvirt.Connect.get_capabilities conn + with + Libvirt.Virterror { message } -> + error (f_"cannot get libvirt hypervisor capabilities: %s") + (Option.default "" message) in debug "libvirt capabilities XML:\n%s" xml; (* This just checks that the capabilities XML is well-formed, @@ -87,7 +96,7 @@ class output_libvirt oc output_pool = object capabilities_doc <- Some doc; (* Does the domain already exist on the target? (RHBZ#889082) *) - if Libvirt_utils.domain_exists ?conn:oc source.s_name then ( + if Libvirt_utils.domain_exists conn source.s_name then ( if source.s_hypervisor = Physical then (* virt-p2v user *) error (f_"a libvirt domain called ‘%s’ already exists on the target.\n\nIf using virt-p2v, select a different ‘Name’ in the ‘Target properties’. Or delete the existing domain on the target using the ‘virsh undefine’ command.") source.s_name @@ -99,7 +108,9 @@ class output_libvirt oc output_pool = object (* Connect to output libvirt instance and check that the pool exists * and dump out its XML. *) - let xml = Libvirt_utils.pool_dumpxml ?conn:oc output_pool in + let xml = + let pool = Libvirt_utils.get_pool conn output_pool in + Libvirt.Pool.get_xml_desc (Libvirt.Pool.const pool) in let doc = Xml.parse_memory xml in let xpathctx = Xml.xpath_new_context doc in let xpath_string = xpath_string xpathctx in diff --git a/v2v/parse_libvirt_xml.ml b/v2v/parse_libvirt_xml.ml index d5d78d367..8f620331c 100644 --- a/v2v/parse_libvirt_xml.ml +++ b/v2v/parse_libvirt_xml.ml @@ -74,6 +74,17 @@ let create_curl_qemu_uri driver host port path = let parse_libvirt_xml ?conn xml = debug "libvirt xml is:\n%s" xml; + (* Create a default libvirt connection on request, to not open one + * in case there is no need to fetch more data (for example inspect + * the storage pools). + *) + let lazy_conn = + lazy (Libvirt.Connect.connect ()) in + let get_conn () = + match conn with + | None -> Lazy.force lazy_conn + | Some conn -> conn in + let doc = Xml.parse_memory xml in let xpathctx = Xml.xpath_new_context doc in let xpath_string = xpath_string xpathctx @@ -333,7 +344,10 @@ let parse_libvirt_xml ?conn xml = (match xpath_string "source/@pool", xpath_string "source/@volume" with | None, None | Some _, None | None, Some _ -> () | Some pool, Some vol -> - let xml = Libvirt_utils.vol_dumpxml ?conn pool vol in + let xml = + let pool = Libvirt_utils.get_pool (get_conn ()) pool in + let vol = Libvirt_utils.get_volume pool vol in + Libvirt.Volume.get_xml_desc (Libvirt.Volume.const vol) in let doc = Xml.parse_memory xml in let xpathctx = Xml.xpath_new_context doc in let xpath_string = Xpath_helpers.xpath_string xpathctx in @@ -511,3 +525,10 @@ let parse_libvirt_xml ?conn xml = s_nics = nics; }, disks) + +let parse_libvirt_domain conn guest = + let dom = Libvirt_utils.get_domain conn guest in + (* Use XmlSecure to get passwords (RHBZ#1174123). *) + let xml = Libvirt.Domain.get_xml_desc_flags dom [Libvirt.Domain.XmlSecure] in + let source, disks = parse_libvirt_xml ~conn xml in + source, disks, xml diff --git a/v2v/parse_libvirt_xml.mli b/v2v/parse_libvirt_xml.mli index 67a8ea96e..2d81e0d99 100644 --- a/v2v/parse_libvirt_xml.mli +++ b/v2v/parse_libvirt_xml.mli @@ -27,7 +27,16 @@ and parsed_source = | P_source_file of string (** <source file> *) | P_dont_rewrite (** s_qemu_uri is already set. *) -val parse_libvirt_xml : ?conn:string -> string -> Types.source * parsed_disk list +val parse_libvirt_domain : Libvirt.rw Libvirt.Connect.t -> string -> Types.source * parsed_disk list * string +(** [parse_libvirt_domain conn dom] loads the XML of the domain [dom] + from the libvirt connection [conn]. + The result is a tuple with a {!Types.source} structure, a list of + source disks, and the XML of the guest. + + {b Note} the [source.s_disks] field is an empty list. The caller + must map over the parsed disks and update the [source.s_disks] field. *) + +val parse_libvirt_xml : ?conn:Libvirt.rw Libvirt.Connect.t -> string -> Types.source * parsed_disk list (** Take libvirt XML and parse it into a {!Types.source} structure and a list of source disks. -- 2.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

Now that we have a proper libvirt connection object, use it directly to refresh the storage pool, and define the final guest. This avoids spawning a new virsh process twice, with no possibility to even share a possible authentication required. --- v2v/output_libvirt.ml | 35 ++++++++++++++++------------------- 1 file changed, 16 insertions(+), 19 deletions(-) diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml index e62e43bb8..e82e95cd9 100644 --- a/v2v/output_libvirt.ml +++ b/v2v/output_libvirt.ml @@ -160,14 +160,14 @@ object (self) (* We copied directly into the final pool directory. However we * have to tell libvirt. *) - let cmd = [ "virsh" ] @ - (if quiet () then [ "-q" ] else []) @ - (match oc with - | None -> [] - | Some uri -> [ "-c"; uri; ]) @ - [ "pool-refresh"; output_pool ] in - if run_command cmd <> 0 then - warning (f_"could not refresh libvirt pool %s") output_pool; + (try + let pool = Libvirt_utils.get_pool self#conn output_pool in + Libvirt.Pool.refresh (Libvirt.Pool.const pool) + with + Libvirt.Virterror { message } -> + warning (f_"could not refresh libvirt pool ‘%s’: %s") + output_pool (Option.default "" message) + ); let pool_name = match pool_name with @@ -198,17 +198,14 @@ object (self) ); (* Define the domain in libvirt. *) - let cmd = [ "virsh" ] @ - (if quiet () then [ "-q" ] else []) @ - (match oc with - | None -> [] - | Some uri -> [ "-c"; uri; ]) @ - [ "define"; tmpfile ] in - if run_command cmd = 0 then ( - try Unix.unlink tmpfile with _ -> () - ) else ( - warning (f_"could not define libvirt domain. The libvirt XML is still available in ‘%s’. Try running ‘virsh define %s’ yourself instead.") - tmpfile tmpfile + (try + ignore (Libvirt.Domain.define_xml self#conn (DOM.doc_to_string doc)); + (try Unix.unlink tmpfile with _ -> ()) + with + Libvirt.Virterror { message } -> + warning (f_"could not define libvirt domain: %s.\nThe libvirt XML is still available in ‘%s’. Try running ‘virsh -c %s define %s’ yourself instead.") + (Option.default "" message) tmpfile + (Libvirt.Connect.get_uri self#conn) tmpfile ); end -- 2.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