Re: [libvirt] [ocaml] event registration APis v3

[David Scott]

Hi,

On 8 May 2013, at 12:32, Richard W.M. Jones rjo...@redhat.com wrote:

 On Wed, Apr 24, 2013 at 11:39:02AM +0100, David Scott wrote:
 Hi,

 Here are my latest patches which add OCaml bindings for the libvirt event
 API. I'm pretty happy with them now: my test programs have been running
 for long periods of time without incident.

 Changes from the previous submission (sent 2013-04-17)
 * added a patch which removes the backwards compatability logic from
   the bindings. The aim is to make the bindings simpler to read and
   develop.

 Changes from the initial submission (sent 2013-03-27)
 * add support for 'deregister_any'
 * fix the ordering of '{enter,leave}_blocking_section' and GC registration
 * add timer callbacks

 Sorry for the long delay in reviewing this.

No problem.

 I have pushed all four patches.

Great!

Thanks,
Dave

 Thanks,

 Rich.

 --
 Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
 virt-df lists disk usage of guests without needing to install any
 software inside the virtual machine.  Supports Linux and Windows.
 http://people.redhat.com/~rjones/virt-df/

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

Re: [libvirt] [PATCH 2/2] libxl: allow an emulator to be selected in the domain config XML

[David Scott]

Jim, Daniel, thanks for all the feedback!

On 29/04/13 20:02, Jim Fehlig wrote:
[ snip ]

As mentioned in my other response [1], your original patch (with a check
to verify the requested emulator exists) should be sufficient.


OK, I'll send an emulator-only patch shortly.

Cheers,
Dave

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] [PATCH] libxl: allow an emulator to be selected in the domain config XML

[David Scott]

The emulator path supplied can be any valid path on the system.

Note that when setting a device_model, libxl needs us to set the
device_model_version too. The device_model_version can be either

  ...QEMU_XEN: meaning upstream qemu, the default in xen-4.3 onwards
  ...QEMU_XEN_TRADITIONAL: the old xen-specific fork

We detect the device_model_version by examining the qemu filename:
if it is qemu-dm then it's the old xen-specific fork. If anything
else then we assume upstream qemu (whose filename may change
in future). Note that if you are using a wrapper script to (eg)
adjust the arguments of the old qemu during development, you will
have to ensure the wrapper script also has the name qemu-dm, by
placing it in a separate directory.

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 src/libxl/libxl_conf.c |   44 
 1 files changed, 44 insertions(+), 0 deletions(-)

diff --git a/src/libxl/libxl_conf.c b/src/libxl/libxl_conf.c
index 7e0753a..2aa5a62 100644
--- a/src/libxl/libxl_conf.c
+++ b/src/libxl/libxl_conf.c
@@ -788,6 +788,46 @@ libxlMakeCapabilities(libxl_ctx *ctx)
 }
 
 int
+libxlMakeEmulator(virDomainDefPtr def, libxl_domain_config *d_config)
+{
+/* No explicit override means use the default */
+if (!def-emulator) {
+return 0;
+}
+
+if (!virFileExists(def-emulator)) {
+virReportError(VIR_ERR_INTERNAL_ERROR,
+   _(emulator '%s' not found),
+   def-emulator);
+return -1;
+}
+
+VIR_FREE(d_config-b_info.device_model);
+if ((d_config-b_info.device_model = strdup(def-emulator)) == NULL) {
+virReportOOMError();
+return -1;
+}
+
+/* N.B. from xen/tools/libxl/libxl_types.idl:
+ * If setting device_model you must set device_model_version too.
+ *
+ * The xen-4.3 and later default is upstream qemu (QEMU_XEN)
+ * so we make that the default and special-case the old-style
+ * traditional qemu (QEMU_XEN_TRADITIONAL)
+ */
+
+d_config-b_info.device_model_version =
+LIBXL_DEVICE_MODEL_VERSION_QEMU_XEN;
+
+if (STREQ(basename(def-emulator), qemu-dm))
+d_config-b_info.device_model_version =
+LIBXL_DEVICE_MODEL_VERSION_QEMU_XEN_TRADITIONAL; 
+
+return 0;
+}
+
+
+int
 libxlBuildDomainConfig(libxlDriverPrivatePtr driver,
virDomainDefPtr def, libxl_domain_config *d_config)
 {
@@ -811,6 +851,10 @@ libxlBuildDomainConfig(libxlDriverPrivatePtr driver,
 goto error;
 }
 
+if (libxlMakeEmulator(def, d_config)  0) {
+goto error;
+}
+
 d_config-on_reboot = def-onReboot;
 d_config-on_poweroff = def-onPoweroff;
 d_config-on_crash = def-onCrash;
-- 
1.7.1

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

Re: [libvirt] [PATCH] libxl: allow an emulator to be selected in the domain config XML

[David Scott]

Hi,

[added xen-devel: FYI this is about how to properly set the libxl 
device_model_version when the user has provided a manual device_model 
override (aka a path to a qemu) in the libvirt domain XML.]


On 30/04/13 16:10, Jim Fehlig wrote:

David Scott wrote:

The emulator path supplied can be any valid path on the system.

Note that when setting a device_model, libxl needs us to set the
device_model_version too. The device_model_version can be either

   ...QEMU_XEN: meaning upstream qemu, the default in xen-4.3 onwards
   ...QEMU_XEN_TRADITIONAL: the old xen-specific fork

We detect the device_model_version by examining the qemu filename:
if it is qemu-dm then it's the old xen-specific fork. If anything
else then we assume upstream qemu (whose filename may change
in future). Note that if you are using a wrapper script to (eg)
adjust the arguments of the old qemu during development, you will
have to ensure the wrapper script also has the name qemu-dm, by
placing it in a separate directory.



That is unfortunate.  Users could have existing config with
emulator/usr/bin/my-qemu-dm/emulator which works with the legacy
stack but not with libxl right?  Is it possible to safely query the
binary to determine if it is qemu-dm?


From my reading of libxl, it doesn't seem to have any way to detect the 
type of a given qemu binary (or at least I couldn't spot it). I think 
that if we were to write some detection code we should probably add it 
to libxl rather than libvirt -- what do you think?


The other options I can think of are:

1. weaken the test so we interpret any filename containing the substring 
qemu-dm as traditional-- this would catch your case at least


2. flip the default around so that if an emulator is provided we 
assume traditional unless the filename is qemu-system-i386 (or maybe 
just contains qemu-system-i386 or contains qemu-system)


3. add libxl driver-specific XML (is that possible?) to allow the user 
to override a libvirt default. It would be a shame to expose the 
complexity to the libvirt client though.


What do you think?

Cheers,
Dave

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

Re: [libvirt] [Xen-devel] libvirt, libxl and QDISKs

[David Scott]

Hi Jim,

Thanks for the explanation about the capabilities.

On 27/04/13 00:44, Jim Fehlig wrote:

Do you have time for an upstream libvirt patch to expose the possible
emulators in the capabilities, along with this patch allowing the user
to specify one?


I'll have a go and send you (cc'ing the libvirt list) what I manage to 
come up with.


Cheers,
Dave

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] libxl: expose and control xen device model versions

[David Scott]

Hi,

These patches expose multiple xen device model options in the
capabilities XML and allow the user to select a specific device
model via the domain XML's emulator tag.

It is important to control the device model per VM, since the
default is changing from xen-4.2 qemu traditional to xen-4.3
qemu upstream.

In this proposal, the capabilities XML now has multiple domain
elements per arch as follows:

arch name='i686'
  wordsize32/wordsize
  machinexenfv/machine
  domain type='xen'
emulator/usr/lib64/xen/bin/qemu-dm/emulator
loader/usr/lib/xen/boot/hvmloader/loader
  /domain
  domain type='xen'
emulator/usr/lib64/xen/bin/qemu-system-i386/emulator
loader/usr/lib/xen/boot/hvmloader/loader
  /domain
/arch

-- is it valid/ sensible to have multiple domain's with the same
'type'? Let me know if you can think of a better mapping.

Comments, criticism welcome.

Cheers,
Dave


--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] [PATCH 1/2] libxl: expose multiple emulators per guest in the capabilities XML

[David Scott]

libxl allows users to choose between two standard emulators:
1. (default in xen-4.2): qemu traditional (aka qemu-dm)
2. (default in xen-4.3): qemu upstream (aka qemu-system-i386)

The person who builds and packages xen gets to choose which
emulators are built. We examine the filesystem for the emulators
at runtime and expose them as separate domains within the same
guest architecture.

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 src/libxl/libxl_conf.c |   87 ---
 1 files changed, 66 insertions(+), 21 deletions(-)

diff --git a/src/libxl/libxl_conf.c b/src/libxl/libxl_conf.c
index 7e0753a..472d116 100644
--- a/src/libxl/libxl_conf.c
+++ b/src/libxl/libxl_conf.c
@@ -29,6 +29,8 @@
 #include libxl.h
 #include sys/types.h
 #include sys/socket.h
+#include sys/stat.h
+#include unistd.h
 
 #include internal.h
 #include virlog.h
@@ -50,6 +52,28 @@
 /* see xen-unstable.hg/xen/include/asm-x86/cpufeature.h */
 #define LIBXL_X86_FEATURE_PAE_MASK 0x40
 
+enum emulator_type {
+emulator_traditional = 0,
+emulator_upstream= 1,
+emulator_last= 2,
+/* extend with specific qemu versions later */
+};
+
+#define EMULATOR_LIB64 /usr/lib64/xen/bin/
+#define EMULATOR_LIB32 /usr/lib/xen/bin/
+
+#define EMULATOR_TRADITIONAL qemu-dm
+#define EMULATOR_UPSTREAMqemu-system-i386
+
+static const char* emulator_lib64_path [] = {
+EMULATOR_LIB64 EMULATOR_TRADITIONAL,
+EMULATOR_LIB64 EMULATOR_UPSTREAM,
+};
+
+static const char* emulator_lib32_path [] = {
+EMULATOR_LIB32 EMULATOR_TRADITIONAL,
+EMULATOR_LIB32 EMULATOR_UPSTREAM,
+};
 
 struct guest_arch {
 virArch arch;
@@ -68,10 +92,11 @@ static virCapsPtr
 libxlBuildCapabilities(virArch hostarch,
int host_pae,
struct guest_arch *guest_archs,
-   int nr_guest_archs)
+   int nr_guest_archs,
+   int emulators_found[])
 {
 virCapsPtr caps;
-int i;
+int i, j;
 
 if ((caps = virCapabilitiesNew(hostarch, 1, 1)) == NULL)
 goto no_memory;
@@ -91,12 +116,8 @@ libxlBuildCapabilities(virArch hostarch,
 if ((guest = virCapabilitiesAddGuest(caps,
  guest_archs[i].hvm ? hvm : 
xen,
  guest_archs[i].arch,
- ((hostarch == VIR_ARCH_X86_64) ?
-  /usr/lib64/xen/bin/qemu-dm :
-  /usr/lib/xen/bin/qemu-dm),
- (guest_archs[i].hvm ?
-  /usr/lib/xen/boot/hvmloader :
-  NULL),
+ NULL,
+ NULL,
  1,
  machines)) == NULL) {
 virCapabilitiesFreeMachines(machines, 1);
@@ -104,13 +125,21 @@ libxlBuildCapabilities(virArch hostarch,
 }
 machines = NULL;
 
-if (virCapabilitiesAddGuestDomain(guest,
-  xen,
-  NULL,
-  NULL,
-  0,
-  NULL) == NULL)
-goto no_memory;
+for (j = 0; j  emulator_last; ++j) {
+if (emulators_found[j] == -1) /* failure from stat(2) */
+continue;
+if (virCapabilitiesAddGuestDomain(guest,
+  xen,
+  ((hostarch == VIR_ARCH_X86_64) ?
+   emulator_lib64_path[j] :
+   emulator_lib32_path[j]),
+  (guest_archs[i].hvm ?
+   /usr/lib/xen/boot/hvmloader :
+   NULL),
+  0,
+  NULL) == NULL)
+goto no_memory;
+}
 
 if (guest_archs[i].pae 
 virCapabilitiesAddGuestFeature(guest,
@@ -163,7 +192,8 @@ libxlBuildCapabilities(virArch hostarch,
 static virCapsPtr
 libxlMakeCapabilitiesInternal(virArch hostarch,
   libxl_physinfo *phy_info,
-  char *capabilities)
+  char *capabilities,
+  int emulators_found[])
 {
 char *str, *token;
 regmatch_t subs[4];
@@ -243,7 +273,7 @@ libxlMakeCapabilitiesInternal(virArch hostarch,
 continue;
 }
 
-/* Search for existing matching (model,hvm) tuple

[libvirt] [PATCH 2/2] libxl: allow an emulator to be selected in the domain config XML

[David Scott]

We cross-check the given path against the capabilties, and translate
it into a libxl_device_model_version.

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 src/libxl/libxl_conf.c |   41 +
 1 files changed, 41 insertions(+), 0 deletions(-)

diff --git a/src/libxl/libxl_conf.c b/src/libxl/libxl_conf.c
index 472d116..868d0cf 100644
--- a/src/libxl/libxl_conf.c
+++ b/src/libxl/libxl_conf.c
@@ -75,6 +75,11 @@ static const char* emulator_lib32_path [] = {
 EMULATOR_LIB32 EMULATOR_UPSTREAM,
 };
 
+static const libxl_device_model_version emulator_to_device_model [] = {
+LIBXL_DEVICE_MODEL_VERSION_QEMU_XEN_TRADITIONAL,
+LIBXL_DEVICE_MODEL_VERSION_QEMU_XEN,
+};
+
 struct guest_arch {
 virArch arch;
 int bits;
@@ -833,6 +838,38 @@ libxlMakeCapabilities(libxl_ctx *ctx)
 }
 
 int
+libxlMakeEmulator(virDomainDefPtr def, libxl_domain_config *d_config)
+{
+virArch hostarch;
+const char *path;
+int i;
+
+/* No explicit override means use the default */
+if (!def-emulator) {
+return 0;
+}
+
+hostarch = virArchFromHost();
+
+for (i = 0; i  emulator_last; ++i) {
+   path = ((hostarch == VIR_ARCH_X86_64) ?
+   emulator_lib64_path[i] :
+   emulator_lib32_path[i]);
+   if (STREQ(path, def-emulator)) {
+   d_config-b_info.device_model_version =
+   emulator_to_device_model[i];
+   return 0;
+   }
+}
+
+virReportError(VIR_ERR_INTERNAL_ERROR,
+   _(libxenlight doesn't support emulator '%s'),
+   def-emulator);
+return -1;
+}
+
+
+int
 libxlBuildDomainConfig(libxlDriverPrivatePtr driver,
virDomainDefPtr def, libxl_domain_config *d_config)
 {
@@ -856,6 +893,10 @@ libxlBuildDomainConfig(libxlDriverPrivatePtr driver,
 goto error;
 }
 
+if (libxlMakeEmulator(def, d_config)  0) {
+goto error;
+}
+
 d_config-on_reboot = def-onReboot;
 d_config-on_poweroff = def-onPoweroff;
 d_config-on_crash = def-onCrash;
-- 
1.7.1

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] [ocaml PATCH 4/4] Add a simple example to show how to receive event callbacks

[David Scott]

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 .gitignore|   1 +
 Makefile.in   |   1 +
 examples/Makefile.in  |  13 -
 examples/domain_events.ml | 145 ++
 4 files changed, 159 insertions(+), 1 deletion(-)
 create mode 100644 examples/domain_events.ml

diff --git a/.gitignore b/.gitignore
index 2b5e4fd..71a245e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -26,6 +26,7 @@ core.*
 *.exe
 *~
 libvirt/libvirt_version.ml
+examples/domain_events
 examples/get_cpu_stats
 examples/list_domains
 examples/node_info
diff --git a/Makefile.in b/Makefile.in
index c0622cc..3b8b7ec 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -40,6 +40,7 @@ clean:
rm -f examples/list_domains
rm -f examples/node_info
rm -f examples/get_cpu_stats
+   rm -f examples/domain_events
 
 distclean: clean
rm -f config.h config.log config.status configure
diff --git a/examples/Makefile.in b/examples/Makefile.in
index 2eb220a..041e382 100644
--- a/examples/Makefile.in
+++ b/examples/Makefile.in
@@ -27,7 +27,7 @@ OCAMLOPTLIBS  := $(OCAMLCLIBS)
 export LIBRARY_PATH=../libvirt
 export LD_LIBRARY_PATH=../libvirt
 
-BYTE_TARGETS   := list_domains node_info get_cpu_stats
+BYTE_TARGETS   := list_domains node_info get_cpu_stats domain_events
 OPT_TARGETS:= $(BYTE_TARGETS:%=%.opt)
 
 all: $(BYTE_TARGETS)
@@ -64,6 +64,17 @@ get_cpu_stats.opt: get_cpu_stats.cmx
  $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
  ../libvirt/mllibvirt.cmxa -o $@ $
 
+domain_events: domain_events.cmo
+   $(OCAMLFIND) ocamlc \
+ $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+ ../libvirt/mllibvirt.cma -o $@ $
+
+domain_events.opt: domain_events.cmx
+   $(OCAMLFIND) ocamlopt \
+ $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+ ../libvirt/mllibvirt.cmxa -o $@ $
+
+
 install-opt install-byte:
 
 include ../Make.rules
diff --git a/examples/domain_events.ml b/examples/domain_events.ml
new file mode 100644
index 000..03cecd9
--- /dev/null
+++ b/examples/domain_events.ml
@@ -0,0 +1,145 @@
+(* Simple demo program showing how to receive domain events.
+   Usage: domain_events [URI]
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   (C) Copyright 2013 Citrix Inc
+   http://libvirt.org/
+ *)
+
+open Printf
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+module E = Libvirt.Event
+module N = Libvirt.Network
+
+let string_of_state = function
+  | D.InfoNoState - no state
+  | D.InfoRunning - running
+  | D.InfoBlocked - blocked
+  | D.InfoPaused - paused
+  | D.InfoShutdown - shutdown
+  | D.InfoShutoff - shutoff
+  | D.InfoCrashed - crashed
+
+let printd dom fmt =
+  let prefix dom =
+let id = D.get_id dom in
+try
+  let name = D.get_name dom in
+  let info = D.get_info dom in
+  let state = string_of_state info.D.state in
+  sprintf %8d %-20s %s  id name state
+  with _ -
+  sprintf %8d  id in
+  let write x =
+output_string stdout (prefix dom);
+output_string stdout x;
+output_string stdout \n;
+flush stdout in
+  Printf.ksprintf write fmt
+
+let string_option = function
+  | None - None
+  | Some x - Some  ^ x
+
+let string_of_graphics_address (family, node, service) =
+  Printf.sprintf { family=%d; node=%s; service=%s } family (string_option 
node) (string_option service)
+
+let string_of_graphics_subject_identity (ty, name) =
+  Printf.sprintf { type=%s; name=%s } (string_option ty) (string_option name)
+
+let string_of_graphics_subject xs = String.concat ;  (List.map 
string_of_graphics_subject_identity (Array.to_list xs))
+
+let map_option f = function
+  | None - None
+  | Some x - Some (f x)
+
+let () =
+  try
+E.register_default_impl ();
+let name =
+  if Array.length Sys.argv = 2 then
+   Some (Sys.argv.(1))
+  else
+   None in
+let conn = C.connect_readonly ?name () in
+
+let spinner = [| '|'; '/'; '-'; '\\' |] in
+
+let timeouts = ref 0 in
+(* Check add/remove works *)
+let id = E.add_timeout conn 250 (fun () - Printf.printf This callback is 
immediately deregistered\n%!) in
+E.remove_timeout conn id;
+
+let (_: E.timer_id) = E.add_timeout conn 250 (* ms *)
+(fun () -
+incr timeouts;
+Printf.printf \r%c  %d timeout callbacks%! (spinner.(!timeouts 
mod (Array.length spinner))) !timeouts;
+(* Check for GC errors: *)
+Gc.compact ()
+) in
+
+(* Check add/remove works *)
+let id = E.register_any conn (E.Lifecycle (fun dom e -
+printd dom Removed Lifecycle callback %s (E.Lifecycle.to_string e)
+)) in
+E.deregister_any conn id;
+
+let (_: E.callback_id) = E.register_any conn (E.Lifecycle (fun dom e -
+printd dom Lifecycle %s (E.Lifecycle.to_string e)
+)) in
+let (_: E.callback_id) = E.register_any conn (E.Reboot (fun dom e -
+printd dom Reboot %s

[libvirt] [ocaml] event registration APis v3

[David Scott]

Hi,

Here are my latest patches which add OCaml bindings for the libvirt event
API. I'm pretty happy with them now: my test programs have been running
for long periods of time without incident. 

Changes from the previous submission (sent 2013-04-17)
 * added a patch which removes the backwards compatability logic from
   the bindings. The aim is to make the bindings simpler to read and
   develop.

Changes from the initial submission (sent 2013-03-27)
 * add support for 'deregister_any'
 * fix the ordering of '{enter,leave}_blocking_section' and GC registration
 * add timer callbacks

Cheers,
Dave

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] [ocaml PATCH 2/4] Add binding for virConnectSetKeepAlive

[David Scott]

This one is a 'one-off' but it ought to be possible to use the generator
to create the function (it has signature 'conn, int, int : int')

This function first appeared in libvirt version 0.9.8.

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 libvirt/libvirt.ml  |  2 ++
 libvirt/libvirt.mli |  8 
 libvirt/libvirt_c_oneoffs.c | 17 +
 3 files changed, 27 insertions(+)

diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index 1fbb8ca..784a2b5 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -100,6 +100,8 @@ struct
   let cpu_usable cpumaps maplen vcpu cpu =
 Char.code 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
+
   external const : [`R] t - ro t = %identity
 end
 
diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli
index 0185402..fa5a0fe 100644
--- a/libvirt/libvirt.mli
+++ b/libvirt/libvirt.mli
@@ -384,6 +384,14 @@ sig
 (** [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. *)
+
   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.
diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index 42301b7..c51aad7 100644
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -169,6 +169,23 @@ ocaml_libvirt_connect_node_get_cells_free_memory (value 
connv,
 }
 
 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, conn, virConnectSetKeepAlive);
+
+  CAMLreturn(Val_unit);
+}
+
+
+CAMLprim value
 ocaml_libvirt_domain_get_id (value domv)
 {
   CAMLparam1 (domv);
-- 
1.8.1.2

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] [ocaml PATCH 3/4] Add event callback implementation based on virConnectDomainEventRegisterAny

[David Scott]

A client may register a callback as follows:

E.register_default_impl ();

let conn = C.connect_readonly ?name () in

let id = E.register_any conn (E.Lifecycle (fun dom e -
printd dom Lifecycle %s (E.Lifecycle.to_string e)
)) in

Internally this will:
  1. generate a unique int64 used to identify the specific callback
  2. add the callback to an OCaml hashtable based on the signature
 (there is a distinct hashtable per callback signature)
  3. call virConnectDomainEventRegisterAny which registers a
 generic C callback in the stubs (one distinct callback per
 signature) and supply the int64 as the opaque data

The client must enter the event loop with:

while true do
E.run_default_impl ()
done

When an event is triggered, the C callback will upcall into an OCaml
function (having re-acquired the heap lock) supplying the int64 value.
The OCaml function can then find the right callback in the Hashtbl
and call it.

The client can deregister the callback with:

  E.deregister_any conn id;

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 libvirt/generator.pl|   2 +
 libvirt/libvirt.ml  | 765 
 libvirt/libvirt.mli | 355 
 libvirt/libvirt_c.c |  19 ++
 libvirt/libvirt_c_oneoffs.c | 411 
 5 files changed, 1552 insertions(+)

diff --git a/libvirt/generator.pl b/libvirt/generator.pl
index ab8900e..8229ad1 100755
--- a/libvirt/generator.pl
+++ b/libvirt/generator.pl
@@ -59,6 +59,8 @@ my @functions = (
 { name = virConnectListDefinedStoragePools,
   sig = conn, int : string array },
 { name = virConnectGetCapabilities, sig = conn : string },
+{ name = virConnectDomainEventDeregisterAny,
+  sig = conn, int : unit },
 
 { name = virDomainCreateLinux, sig = conn, string, 0U : dom },
 { name = virDomainFree, sig = dom : free },
diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index 784a2b5..9c9368a 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -483,6 +483,771 @@ struct
 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

Re: [libvirt] [PATCH 2/3][ocaml] Add event callback implementation based on virConnectDomainEventRegisterAny

[David Scott]

Hi,

I just spotted a flaw in my OCaml event callback patch. I was hoping to
ensure the ocaml bindings build against libvirt 0.9.1 and later. For
functions, I remembered to include the usual symbol detection magic.
However I forgot that there are also some enums which were added later than
0.9.1 i.e. all of these:

On Wed, Apr 17, 2013 at 11:16 AM, David Scott scott...@gmail.com wrote:

[snip]

 +  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;


These currently cause the build to break against older libvirts.

I'll rework this and resubmit once I've verified it definitely does work
against an older version.

Sorry for the noise!

Cheers,
Dave
--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] (no subject)

[David Scott]

Hi,

I've made an improved set of ocaml bindings for the libvirt event
mechanism which I'm now reasonably happy with. Improvements since
my first submission:

1. it's possible to deregister callbacks with 'deregister_any'
2. the callback to ocaml now re-acquires the heap lock *before*
   creating and registering OCaml values with the GC: the previous
   patches got this wrong and bad things happened
3. it's possible to add and remove timer callbacks: this is used
   in the example to run Gc.compact() often, to check for problems
4. I removed the symbol detection for bindings present in libvirt
   0.9.1

Let me know what you think!

Thanks,
Dave

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] [PATCH 1/3] Add binding for virConnectSetKeepAlive

[David Scott]

This one is a 'one-off' but it ought to be possible to use the generator
to create the function (it has signature 'conn, int, int : int')

This function first appeared in libvirt version 0.9.8.

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 config.h.in |  3 +++
 configure.ac|  1 +
 libvirt/.depend | 12 ++--
 libvirt/libvirt.ml  |  2 ++
 libvirt/libvirt.mli |  8 
 libvirt/libvirt_c_oneoffs.c | 28 
 6 files changed, 48 insertions(+), 6 deletions(-)

diff --git a/config.h.in b/config.h.in
index fccbbe7..72bda13 100644
--- a/config.h.in
+++ b/config.h.in
@@ -30,6 +30,9 @@
 /* Define to 1 if you have the unistd.h header file. */
 #undef HAVE_UNISTD_H
 
+/* Define to 1 if you have the 'virConnectSetKeepAlive' function. */
+#undef HAVE_VIRCONNECTSETKEEPALIVE
+
 /* Define to 1 if you have the `virConnectGetHostname' function. */
 #undef HAVE_VIRCONNECTGETHOSTNAME
 
diff --git a/configure.ac b/configure.ac
index 63635b6..9812bf4 100644
--- a/configure.ac
+++ b/configure.ac
@@ -126,6 +126,7 @@ AC_CHECK_FUNCS([virConnectGetHostname \
virDomainBlockPeek \
virDomainMemoryPeek \
 virDomainGetCPUStats \
+virConnectSetKeepAlive \
 ])
 
 dnl Check for optional types added since 0.2.1.
diff --git a/libvirt/.depend b/libvirt/.depend
index 7d32e13..3f2297e 100644
--- a/libvirt/.depend
+++ b/libvirt/.depend
@@ -1,6 +1,6 @@
-libvirt_version.cmi :
-libvirt.cmi :
-libvirt_version.cmo : libvirt_version.cmi
-libvirt_version.cmx : libvirt_version.cmi
-libvirt.cmo : libvirt.cmi
-libvirt.cmx : libvirt.cmi
+libvirt.cmi:
+libvirt_version.cmi:
+libvirt.cmo: libvirt.cmi
+libvirt.cmx: libvirt.cmi
+libvirt_version.cmo: libvirt_version.cmi
+libvirt_version.cmx: libvirt_version.cmi
diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index 1fbb8ca..784a2b5 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -100,6 +100,8 @@ struct
   let cpu_usable cpumaps maplen vcpu cpu =
 Char.code 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
+
   external const : [`R] t - ro t = %identity
 end
 
diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli
index bf95fa2..a106a64 100644
--- a/libvirt/libvirt.mli
+++ b/libvirt/libvirt.mli
@@ -391,6 +391,14 @@ sig
 (** [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. *)
+
   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.
diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index 70cf96f..7506ab0 100644
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -194,6 +194,34 @@ ocaml_libvirt_connect_node_get_cells_free_memory (value 
connv,
 #endif
 }
 
+#ifdef HAVE_WEAK_SYMBOLS
+#ifdef HAVE_VIRCONNECTSETKEEPALIVE
+extern int virConnectSetKeepAlive (virConnectPtr conn, int interval, unsigned 
int count)
+  __attribute__((weak));
+#endif
+#endif
+
+CAMLprim value
+ocaml_libvirt_connect_set_keep_alive(value connv,
+value intervalv, value countv)
+{
+#ifdef HAVE_VIRCONNECTSETKEEPALIVE
+  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, conn, virConnectSetKeepAlive);
+
+  CAMLreturn(Val_unit);
+#else
+  not_supported (virConnectSetKeepAlive);
+#endif
+}
+
+
 CAMLprim value
 ocaml_libvirt_domain_get_id (value domv)
 {
-- 
1.8.1.2

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] [PATCH 3/3] Add a simple example to show how to receive event callbacks

[David Scott]

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 .gitignore|   1 +
 Makefile.in   |   1 +
 examples/.depend  |  14 +++--
 examples/Makefile.in  |  13 -
 examples/domain_events.ml | 145 ++
 5 files changed, 167 insertions(+), 7 deletions(-)
 create mode 100644 examples/domain_events.ml

diff --git a/.gitignore b/.gitignore
index 2b5e4fd..71a245e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -26,6 +26,7 @@ core.*
 *.exe
 *~
 libvirt/libvirt_version.ml
+examples/domain_events
 examples/get_cpu_stats
 examples/list_domains
 examples/node_info
diff --git a/Makefile.in b/Makefile.in
index c0622cc..3b8b7ec 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -40,6 +40,7 @@ clean:
rm -f examples/list_domains
rm -f examples/node_info
rm -f examples/get_cpu_stats
+   rm -f examples/domain_events
 
 distclean: clean
rm -f config.h config.log config.status configure
diff --git a/examples/.depend b/examples/.depend
index 3d955f9..8e4f133 100644
--- a/examples/.depend
+++ b/examples/.depend
@@ -1,6 +1,8 @@
-node_info.cmo : ../libvirt/libvirt.cmi
-node_info.cmx : ../libvirt/libvirt.cmx
-get_cpu_stats.cmo : ../libvirt/libvirt.cmi
-get_cpu_stats.cmx : ../libvirt/libvirt.cmx
-list_domains.cmo : ../libvirt/libvirt.cmi
-list_domains.cmx : ../libvirt/libvirt.cmx
+domain_events.cmo: ../libvirt/libvirt.cmi
+domain_events.cmx: ../libvirt/libvirt.cmx
+get_cpu_stats.cmo: ../libvirt/libvirt.cmi
+get_cpu_stats.cmx: ../libvirt/libvirt.cmx
+list_domains.cmo: ../libvirt/libvirt.cmi
+list_domains.cmx: ../libvirt/libvirt.cmx
+node_info.cmo: ../libvirt/libvirt.cmi
+node_info.cmx: ../libvirt/libvirt.cmx
diff --git a/examples/Makefile.in b/examples/Makefile.in
index 2eb220a..041e382 100644
--- a/examples/Makefile.in
+++ b/examples/Makefile.in
@@ -27,7 +27,7 @@ OCAMLOPTLIBS  := $(OCAMLCLIBS)
 export LIBRARY_PATH=../libvirt
 export LD_LIBRARY_PATH=../libvirt
 
-BYTE_TARGETS   := list_domains node_info get_cpu_stats
+BYTE_TARGETS   := list_domains node_info get_cpu_stats domain_events
 OPT_TARGETS:= $(BYTE_TARGETS:%=%.opt)
 
 all: $(BYTE_TARGETS)
@@ -64,6 +64,17 @@ get_cpu_stats.opt: get_cpu_stats.cmx
  $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
  ../libvirt/mllibvirt.cmxa -o $@ $
 
+domain_events: domain_events.cmo
+   $(OCAMLFIND) ocamlc \
+ $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+ ../libvirt/mllibvirt.cma -o $@ $
+
+domain_events.opt: domain_events.cmx
+   $(OCAMLFIND) ocamlopt \
+ $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+ ../libvirt/mllibvirt.cmxa -o $@ $
+
+
 install-opt install-byte:
 
 include ../Make.rules
diff --git a/examples/domain_events.ml b/examples/domain_events.ml
new file mode 100644
index 000..03cecd9
--- /dev/null
+++ b/examples/domain_events.ml
@@ -0,0 +1,145 @@
+(* Simple demo program showing how to receive domain events.
+   Usage: domain_events [URI]
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   (C) Copyright 2013 Citrix Inc
+   http://libvirt.org/
+ *)
+
+open Printf
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+module E = Libvirt.Event
+module N = Libvirt.Network
+
+let string_of_state = function
+  | D.InfoNoState - no state
+  | D.InfoRunning - running
+  | D.InfoBlocked - blocked
+  | D.InfoPaused - paused
+  | D.InfoShutdown - shutdown
+  | D.InfoShutoff - shutoff
+  | D.InfoCrashed - crashed
+
+let printd dom fmt =
+  let prefix dom =
+let id = D.get_id dom in
+try
+  let name = D.get_name dom in
+  let info = D.get_info dom in
+  let state = string_of_state info.D.state in
+  sprintf %8d %-20s %s  id name state
+  with _ -
+  sprintf %8d  id in
+  let write x =
+output_string stdout (prefix dom);
+output_string stdout x;
+output_string stdout \n;
+flush stdout in
+  Printf.ksprintf write fmt
+
+let string_option = function
+  | None - None
+  | Some x - Some  ^ x
+
+let string_of_graphics_address (family, node, service) =
+  Printf.sprintf { family=%d; node=%s; service=%s } family (string_option 
node) (string_option service)
+
+let string_of_graphics_subject_identity (ty, name) =
+  Printf.sprintf { type=%s; name=%s } (string_option ty) (string_option name)
+
+let string_of_graphics_subject xs = String.concat ;  (List.map 
string_of_graphics_subject_identity (Array.to_list xs))
+
+let map_option f = function
+  | None - None
+  | Some x - Some (f x)
+
+let () =
+  try
+E.register_default_impl ();
+let name =
+  if Array.length Sys.argv = 2 then
+   Some (Sys.argv.(1))
+  else
+   None in
+let conn = C.connect_readonly ?name () in
+
+let spinner = [| '|'; '/'; '-'; '\\' |] in
+
+let timeouts = ref 0 in
+(* Check add/remove works *)
+let id = E.add_timeout conn 250 (fun () - Printf.printf This callback is 
immediately deregistered\n%!) in
+E.remove_timeout conn id;
+
+let

[libvirt] [PATCH 2/3] Add event callback implementation based on virConnectDomainEventRegisterAny

[David Scott]

A client may register a callback as follows:

E.register_default_impl ();

let conn = C.connect_readonly ?name () in

let id = E.register_any conn (E.Lifecycle (fun dom e -
printd dom Lifecycle %s (E.Lifecycle.to_string e)
)) in

Internally this will:
  1. generate a unique int64 used to identify the specific callback
  2. add the callback to an OCaml hashtable based on the signature
 (there is a distinct hashtable per callback signature)
  3. call virConnectDomainEventRegisterAny which registers a
 generic C callback in the stubs (one distinct callback per
 signature) and supply the int64 as the opaque data

The client must enter the event loop with:

while true do
E.run_default_impl ()
done

When an event is triggered, the C callback will upcall into an OCaml
function (having re-acquired the heap lock) supplying the int64 value.
The OCaml function can then find the right callback in the Hashtbl
and call it.

The client can deregister the callback with:

  E.deregister_any conn id;

The functions
  virEvent{Add,Remove}Timeout
were added in libvirt 0.9.3 so we include the weak symbol check.

The functions
  virConnectDomainEvent{Register,Deregister}Any
  virEventRegisterDefaultImpl
  virEventRunDefaultImpl
were present in libvirt 0.9.1 so we always assume the symbols are
present.

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 config.h.in |   6 +
 configure.ac|   2 +
 libvirt/generator.pl|   2 +
 libvirt/libvirt.ml  | 765 
 libvirt/libvirt.mli | 355 
 libvirt/libvirt_c.c |  19 ++
 libvirt/libvirt_c_oneoffs.c | 445 ++
 7 files changed, 1594 insertions(+)

diff --git a/config.h.in b/config.h.in
index 72bda13..544c22c 100644
--- a/config.h.in
+++ b/config.h.in
@@ -80,6 +80,12 @@
 /* Define to 1 if you have the `virDomainSetSchedulerParameters' function. */
 #undef HAVE_VIRDOMAINSETSCHEDULERPARAMETERS
 
+/* Define to 1 if you have the `virEventAddTimeout' function. */
+#undef HAVE_VIREVENTADDTIMEOUT
+
+/* Define to 1 if you have the `virEventRemoveTimeout' function. */
+#undef HAVE_VIREVENTREMOVETIMEOUT
+
 /* Define to 1 if you have the `virNodeGetCellsFreeMemory' function. */
 #undef HAVE_VIRNODEGETCELLSFREEMEMORY
 
diff --git a/configure.ac b/configure.ac
index 9812bf4..1c9f2bf 100644
--- a/configure.ac
+++ b/configure.ac
@@ -127,6 +127,8 @@ AC_CHECK_FUNCS([virConnectGetHostname \
virDomainMemoryPeek \
 virDomainGetCPUStats \
 virConnectSetKeepAlive \
+virEventAddTimeout \
+virEventRemoveTimeout \
 ])
 
 dnl Check for optional types added since 0.2.1.
diff --git a/libvirt/generator.pl b/libvirt/generator.pl
index abebfff..eeb9f42 100755
--- a/libvirt/generator.pl
+++ b/libvirt/generator.pl
@@ -61,6 +61,8 @@ my @functions = (
 { name = virConnectListDefinedStoragePools,
   sig = conn, int : string array, weak = 1 },
 { name = virConnectGetCapabilities, sig = conn : string },
+{ name = virConnectDomainEventDeregisterAny,
+  sig = conn, int : unit },
 
 { name = virDomainCreateLinux, sig = conn, string, 0U : dom },
 { name = virDomainFree, sig = dom : free },
diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index 784a2b5..9c9368a 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -483,6 +483,771 @@ struct
 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

[libvirt] [PATCH] Fix typo in ocaml_libvirt_storage_vol_get_info

[David Scott]

The info.capacity was being overwritten with the info.allocation.

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 libvirt/libvirt_c_oneoffs.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index 80e1c03..01985f5 100644
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -1418,7 +1418,7 @@ ocaml_libvirt_storage_vol_get_info (value volv)
   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, 1, v);
+  v = caml_copy_int64 (info.allocation); Store_field (rv, 2, v);
 
   CAMLreturn (rv);
 #else
-- 
1.8.1.2

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] [PATCH 1/3] Add binding for virConnectSetKeepAlive

[David Scott]

This one is a 'one-off' but it ought to be possible to use the generator
to create the function (it has signature 'conn, int, int : int')

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 config.h.in |3 +++
 configure.ac|1 +
 libvirt/.depend |   12 ++--
 libvirt/libvirt.ml  |2 ++
 libvirt/libvirt.mli |8 
 libvirt/libvirt_c_oneoffs.c |   28 
 6 files changed, 48 insertions(+), 6 deletions(-)

diff --git a/config.h.in b/config.h.in
index fccbbe7..72bda13 100644
--- a/config.h.in
+++ b/config.h.in
@@ -30,6 +30,9 @@
 /* Define to 1 if you have the unistd.h header file. */
 #undef HAVE_UNISTD_H
 
+/* Define to 1 if you have the 'virConnectSetKeepAlive' function. */
+#undef HAVE_VIRCONNECTSETKEEPALIVE
+
 /* Define to 1 if you have the `virConnectGetHostname' function. */
 #undef HAVE_VIRCONNECTGETHOSTNAME
 
diff --git a/configure.ac b/configure.ac
index 63635b6..9812bf4 100644
--- a/configure.ac
+++ b/configure.ac
@@ -126,6 +126,7 @@ AC_CHECK_FUNCS([virConnectGetHostname \
virDomainBlockPeek \
virDomainMemoryPeek \
 virDomainGetCPUStats \
+virConnectSetKeepAlive \
 ])
 
 dnl Check for optional types added since 0.2.1.
diff --git a/libvirt/.depend b/libvirt/.depend
index 7d32e13..3f2297e 100644
--- a/libvirt/.depend
+++ b/libvirt/.depend
@@ -1,6 +1,6 @@
-libvirt_version.cmi :
-libvirt.cmi :
-libvirt_version.cmo : libvirt_version.cmi
-libvirt_version.cmx : libvirt_version.cmi
-libvirt.cmo : libvirt.cmi
-libvirt.cmx : libvirt.cmi
+libvirt.cmi:
+libvirt_version.cmi:
+libvirt.cmo: libvirt.cmi
+libvirt.cmx: libvirt.cmi
+libvirt_version.cmo: libvirt_version.cmi
+libvirt_version.cmx: libvirt_version.cmi
diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index 1fbb8ca..784a2b5 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -100,6 +100,8 @@ struct
   let cpu_usable cpumaps maplen vcpu cpu =
 Char.code 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
+
   external const : [`R] t - ro t = %identity
 end
 
diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli
index bf95fa2..a106a64 100644
--- a/libvirt/libvirt.mli
+++ b/libvirt/libvirt.mli
@@ -391,6 +391,14 @@ sig
 (** [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. *)
+
   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.
diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index 70cf96f..7506ab0 100644
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -194,6 +194,34 @@ ocaml_libvirt_connect_node_get_cells_free_memory (value 
connv,
 #endif
 }
 
+#ifdef HAVE_WEAK_SYMBOLS
+#ifdef HAVE_VIRCONNECTSETKEEPALIVE
+extern int virConnectSetKeepAlive (virConnectPtr conn, int interval, unsigned 
int count)
+  __attribute__((weak));
+#endif
+#endif
+
+CAMLprim value
+ocaml_libvirt_connect_set_keep_alive(value connv,
+value intervalv, value countv)
+{
+#ifdef HAVE_VIRCONNECTSETKEEPALIVE
+  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, conn, virConnectSetKeepAlive);
+
+  CAMLreturn(Val_unit);
+#else
+  not_supported (virConnectSetKeepAlive);
+#endif
+}
+
+
 CAMLprim value
 ocaml_libvirt_domain_get_id (value domv)
 {
-- 
1.7.10.4

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] ocaml: prototype bindings for event callbacks

[David Scott]

Hi,

I've made an prototype set of ocaml bindings for the libvirt event
mechanism -- here is what I've got so far.

It's possible to register for all the types supported by

  virConnectDomainEventRegisterAny

I've not tested each type of event yet, but the basics are all working.

For every distinct callback function signature it maintains:

  1. OCaml: a hashtable mapping callback_id (int64) to a specific closure
  2. OCaml: a function registered with Callback.register
  3. C: a function registered with libvirt, which upcalls to OCaml

There's still some missing polish, for example I've not implemented a
means to actually deregister a callback :-) I thought it would be best
to get feedback on the overall approach, style of the mapping etc first.

Comments and criticism greatly appreciated!

Thanks,
Dave

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] [PATCH 3/3] Add a simple example to show how to receive event callbacks

[David Scott]

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 .gitignore|1 +
 Makefile.in   |1 +
 examples/.depend  |   14 ++---
 examples/Makefile.in  |   13 -
 examples/domain_events.ml |  124 +
 5 files changed, 146 insertions(+), 7 deletions(-)
 create mode 100644 examples/domain_events.ml

diff --git a/.gitignore b/.gitignore
index 2b5e4fd..71a245e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -26,6 +26,7 @@ core.*
 *.exe
 *~
 libvirt/libvirt_version.ml
+examples/domain_events
 examples/get_cpu_stats
 examples/list_domains
 examples/node_info
diff --git a/Makefile.in b/Makefile.in
index c0622cc..3b8b7ec 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -40,6 +40,7 @@ clean:
rm -f examples/list_domains
rm -f examples/node_info
rm -f examples/get_cpu_stats
+   rm -f examples/domain_events
 
 distclean: clean
rm -f config.h config.log config.status configure
diff --git a/examples/.depend b/examples/.depend
index 3d955f9..8e4f133 100644
--- a/examples/.depend
+++ b/examples/.depend
@@ -1,6 +1,8 @@
-node_info.cmo : ../libvirt/libvirt.cmi
-node_info.cmx : ../libvirt/libvirt.cmx
-get_cpu_stats.cmo : ../libvirt/libvirt.cmi
-get_cpu_stats.cmx : ../libvirt/libvirt.cmx
-list_domains.cmo : ../libvirt/libvirt.cmi
-list_domains.cmx : ../libvirt/libvirt.cmx
+domain_events.cmo: ../libvirt/libvirt.cmi
+domain_events.cmx: ../libvirt/libvirt.cmx
+get_cpu_stats.cmo: ../libvirt/libvirt.cmi
+get_cpu_stats.cmx: ../libvirt/libvirt.cmx
+list_domains.cmo: ../libvirt/libvirt.cmi
+list_domains.cmx: ../libvirt/libvirt.cmx
+node_info.cmo: ../libvirt/libvirt.cmi
+node_info.cmx: ../libvirt/libvirt.cmx
diff --git a/examples/Makefile.in b/examples/Makefile.in
index 2eb220a..041e382 100644
--- a/examples/Makefile.in
+++ b/examples/Makefile.in
@@ -27,7 +27,7 @@ OCAMLOPTLIBS  := $(OCAMLCLIBS)
 export LIBRARY_PATH=../libvirt
 export LD_LIBRARY_PATH=../libvirt
 
-BYTE_TARGETS   := list_domains node_info get_cpu_stats
+BYTE_TARGETS   := list_domains node_info get_cpu_stats domain_events
 OPT_TARGETS:= $(BYTE_TARGETS:%=%.opt)
 
 all: $(BYTE_TARGETS)
@@ -64,6 +64,17 @@ get_cpu_stats.opt: get_cpu_stats.cmx
  $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
  ../libvirt/mllibvirt.cmxa -o $@ $
 
+domain_events: domain_events.cmo
+   $(OCAMLFIND) ocamlc \
+ $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+ ../libvirt/mllibvirt.cma -o $@ $
+
+domain_events.opt: domain_events.cmx
+   $(OCAMLFIND) ocamlopt \
+ $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+ ../libvirt/mllibvirt.cmxa -o $@ $
+
+
 install-opt install-byte:
 
 include ../Make.rules
diff --git a/examples/domain_events.ml b/examples/domain_events.ml
new file mode 100644
index 000..a554ea9
--- /dev/null
+++ b/examples/domain_events.ml
@@ -0,0 +1,124 @@
+(* Simple demo program showing how to receive domain events.
+   Usage: domain_events [URI]
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   (C) Copyright 2013 Citrix Inc
+   http://libvirt.org/
+ *)
+
+open Printf
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+module E = Libvirt.Event
+module N = Libvirt.Network
+
+let string_of_state = function
+  | D.InfoNoState - no state
+  | D.InfoRunning - running
+  | D.InfoBlocked - blocked
+  | D.InfoPaused - paused
+  | D.InfoShutdown - shutdown
+  | D.InfoShutoff - shutoff
+  | D.InfoCrashed - crashed
+
+let printd dom fmt =
+  let prefix dom =
+let id = D.get_id dom in
+try
+  let name = D.get_name dom in
+  let info = D.get_info dom in
+  let state = string_of_state info.D.state in
+  sprintf %8d %-20s %s  id name state
+  with _ -
+  sprintf %8d  id in
+  let write x =
+output_string stdout (prefix dom);
+output_string stdout x;
+output_string stdout \n;
+flush stdout in
+  Printf.ksprintf write fmt
+
+let string_option = function
+  | None - None
+  | Some x - Some  ^ x
+
+let string_of_graphics_address (family, node, service) =
+  Printf.sprintf { family=%d; node=%s; service=%s } family (string_option 
node) (string_option service)
+
+let string_of_graphics_subject_identity (ty, name) =
+  Printf.sprintf { type=%s; name=%s } (string_option ty) (string_option name)
+
+let string_of_graphics_subject xs = String.concat ;  (List.map 
string_of_graphics_subject_identity (Array.to_list xs))
+
+let map_option f = function
+  | None - None
+  | Some x - Some (f x)
+
+let () =
+  try
+E.register_default_impl ();
+let name =
+  if Array.length Sys.argv = 2 then
+   Some (Sys.argv.(1))
+  else
+   None in
+let conn = C.connect_readonly ?name () in
+
+E.register_any conn (E.Lifecycle (fun dom e -
+printd dom Lifecycle %s (E.Lifecycle.to_string e)
+));
+E.register_any conn (E.Reboot (fun dom e -
+printd dom Reboot %s (E.Reboot.to_string e)
+));
+E.register_any conn

[libvirt] [PATCH 2/3] Add event callback implementation based on virConnectDomainEventRegisterAny

[David Scott]

A client may register a callback as follows:

E.register_default_impl ();

let conn = C.connect_readonly ?name () in

E.register_any conn (E.Lifecycle (fun dom e -
printd dom Lifecycle %s (E.Lifecycle.to_string e)
));

Internally this will:
  1. generate a unique int64 used to identify the specific callback
  2. add the callback to an OCaml hashtable based on the signature
 (there is a distinct hashtable per callback signature)
  3. call virConnectDomainEventRegisterAny which registers a
 generic C callback in the stubs (one distinct callback per
 signature) and supply the int64 as the opaque data

The client must enter the event loop with:

while true do
E.run_default_impl ()
done

When an event is triggered, the C callback will upcall into an OCaml
function (having re-acquired the heap lock) supplying the int64 value.
The OCaml function can then find the right callback in the Hashtbl
and call it.

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 config.h.in |9 +
 configure.ac|3 +
 libvirt/libvirt.ml  |  714 +++
 libvirt/libvirt.mli |  337 
 libvirt/libvirt_c_oneoffs.c |  387 ++-
 5 files changed, 1449 insertions(+), 1 deletion(-)

diff --git a/config.h.in b/config.h.in
index 72bda13..1e1b137 100644
--- a/config.h.in
+++ b/config.h.in
@@ -30,6 +30,9 @@
 /* Define to 1 if you have the unistd.h header file. */
 #undef HAVE_UNISTD_H
 
+/* Define to 1 if you have the `virConnectDomainEventRegisterAny' function. */
+#undef HAVE_VIRCONNECTDOMAINEVENTREGISTERANY
+
 /* Define to 1 if you have the 'virConnectSetKeepAlive' function. */
 #undef HAVE_VIRCONNECTSETKEEPALIVE
 
@@ -80,6 +83,12 @@
 /* Define to 1 if you have the `virDomainSetSchedulerParameters' function. */
 #undef HAVE_VIRDOMAINSETSCHEDULERPARAMETERS
 
+/* Define to 1 if you have the `virEventRegisterDefaultImpl' function. */
+#undef HAVE_VIREVENTREGISTERDEFAULTIMPL
+
+/* Define to 1 if you have the `virEventRunDefaultImpl' function. */
+#undef HAVE_VIREVENTRUNDEFAULTIMPL
+
 /* Define to 1 if you have the `virNodeGetCellsFreeMemory' function. */
 #undef HAVE_VIRNODEGETCELLSFREEMEMORY
 
diff --git a/configure.ac b/configure.ac
index 9812bf4..5013957 100644
--- a/configure.ac
+++ b/configure.ac
@@ -126,6 +126,9 @@ AC_CHECK_FUNCS([virConnectGetHostname \
virDomainBlockPeek \
virDomainMemoryPeek \
 virDomainGetCPUStats \
+virEventRegisterDefaultImpl \
+virEventRunDefaultImpl \
+virConnectDomainEventRegisterAny \
 virConnectSetKeepAlive \
 ])
 
diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index 784a2b5..88310bf 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -483,6 +483,720 @@ struct
 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

[libvirt] [PATCH 3/3] Functions returning unit correspond to C fns which use -1 for failure

[David Scott]

This affects the following functions:
  virStoragePoolBuild
  virStoragePoolDelete
  virStorageVolDelete

Previously a call to virStorageVolDelete would succeed returning 0, which
was interpreted as false, causing us to raise an exception with
VIR_ERR_NONE.

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 libvirt/generator.pl |2 +-
 libvirt/libvirt_c.c  |6 +++---
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/libvirt/generator.pl b/libvirt/generator.pl
index 8590ea7..abebfff 100755
--- a/libvirt/generator.pl
+++ b/libvirt/generator.pl
@@ -749,7 +749,7 @@ sub gen_c_code
   int r;
 
   NONBLOCKING (r = $c_name ($1, i));
-  CHECK_ERROR (!r, conn, \$c_name\);
+  CHECK_ERROR (r == -1, conn, \$c_name\);
 
   CAMLreturn (Val_unit);
 
diff --git a/libvirt/libvirt_c.c b/libvirt/libvirt_c.c
index b1f084b..d07a55e 100644
--- a/libvirt/libvirt_c.c
+++ b/libvirt/libvirt_c.c
@@ -1932,7 +1932,7 @@ ocaml_libvirt_storage_pool_build (value poolv, value iv)
   int r;
 
   NONBLOCKING (r = virStoragePoolBuild (pool, i));
-  CHECK_ERROR (!r, conn, virStoragePoolBuild);
+  CHECK_ERROR (r == -1, conn, virStoragePoolBuild);
 
   CAMLreturn (Val_unit);
 #endif
@@ -2038,7 +2038,7 @@ ocaml_libvirt_storage_pool_delete (value poolv, value iv)
   int r;
 
   NONBLOCKING (r = virStoragePoolDelete (pool, i));
-  CHECK_ERROR (!r, conn, virStoragePoolDelete);
+  CHECK_ERROR (r == -1, conn, virStoragePoolDelete);
 
   CAMLreturn (Val_unit);
 #endif
@@ -2309,7 +2309,7 @@ ocaml_libvirt_storage_vol_delete (value volv, value iv)
   int r;
 
   NONBLOCKING (r = virStorageVolDelete (vol, i));
-  CHECK_ERROR (!r, conn, virStorageVolDelete);
+  CHECK_ERROR (r == -1, conn, virStorageVolDelete);
 
   CAMLreturn (Val_unit);
 #endif
-- 
1.7.10.4

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] [PATCH 1/3] Correct typos in the storage interface's phantom types

[David Scott]

A connection is either read/write (type rw = [`R|`W]) or read/only
(type ro = [`R]). A function which requires the ability to write
needs to take a parameter [ `W] rather than [`W] (which would
correspond to a write-only connection).

We can now use a read/write connection to call:
  Pool.set_autostart
  Volume.create_xml
  Volume.delete

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 libvirt/libvirt.ml  |6 +++---
 libvirt/libvirt.mli |6 +++---
 2 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index 07542a9..443b22b 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -536,7 +536,7 @@ struct
   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 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
@@ -562,8 +562,8 @@ struct
   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 - unit = ocaml_libvirt_storage_vol_delete
+  external create_xml : [`W] Pool.t - xml - unit = 
ocaml_libvirt_storage_vol_create_xml
+  external delete : [`W] t - unit = ocaml_libvirt_storage_vol_delete
   external free : [`R] t - unit = ocaml_libvirt_storage_vol_free
   external const : [`R] t - ro t = %identity
 end
diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli
index 5a288c0..70cc2c7 100644
--- a/libvirt/libvirt.mli
+++ b/libvirt/libvirt.mli
@@ -757,7 +757,7 @@ sig
 (** 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
+  val set_autostart : [`W] t - bool - unit
 (** Set the autostart flag for the storage pool. *)
 
   val num_of_volumes : [`R] t - int
@@ -810,9 +810,9 @@ sig
   val get_xml_desc : [`R] t - xml
 (** Get the XML description. *)
 
-  val create_xml : [`W] Pool.t - xml - unit
+  val create_xml : [`W] Pool.t - xml - unit
 (** Create a storage volume. *)
-  val delete : [`W] t - unit
+  val delete : [`W] t - unit
 (** Delete a storage volume. *)
   val free : [`R] t - unit
 (** Free a storage volume object in memory.
-- 
1.7.10.4

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] [PATCH 2/3] Volume.delete takes a flags parameter

[David Scott]

This corrects a mismatch between the generated C stubs and the .ml
interface.

Signed-off-by: David Scott dave.sc...@eu.citrix.com
---
 libvirt/libvirt.ml  |2 +-
 libvirt/libvirt.mli |2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index 443b22b..1fbb8ca 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -563,7 +563,7 @@ struct
   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 - unit = ocaml_libvirt_storage_vol_delete
+  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
diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli
index 70cc2c7..bf95fa2 100644
--- a/libvirt/libvirt.mli
+++ b/libvirt/libvirt.mli
@@ -812,7 +812,7 @@ sig
 
   val create_xml : [`W] Pool.t - xml - unit
 (** Create a storage volume. *)
-  val delete : [`W] t - unit
+  val delete : [`W] t - vol_delete_flags - unit
 (** Delete a storage volume. *)
   val free : [`R] t - unit
 (** Free a storage volume object in memory.
-- 
1.7.10.4

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

[libvirt] Minor fixes to ocaml bindings for storage pools/volumes

[David Scott]

These patches fix a couple of minor issues I encountered while
trying to manipulate storage pools and volumes from an OCaml
program.

If you're interested, the OCaml client code is a simple adapter
to allow an XCP host to use libvirt (for storage only atm, more
later). The client code (so far) is here:

https://github.com/djs55/xcp-libvirt-storage/blob/master/server.ml

Cheers,
Dave Scott
http://dave.recoil.org/

--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list

Re: [libvirt] Minor fixes to ocaml bindings for storage pools/volumes

[David Scott]

On Wed, Mar 6, 2013 at 5:01 PM, Richard W.M. Jones rjo...@redhat.comwrote:

 On Wed, Mar 06, 2013 at 04:18:02PM +, David Scott wrote:
  These patches fix a couple of minor issues I encountered while
  trying to manipulate storage pools and volumes from an OCaml
  program.
 
  If you're interested, the OCaml client code is a simple adapter
  to allow an XCP host to use libvirt (for storage only atm, more
  later). The client code (so far) is here:
 
  https://github.com/djs55/xcp-libvirt-storage/blob/master/server.ml

 Thanks -- I just pushed all 3 patches.


Great :-)

Generally I find the OCaml bindings very nice to use. IMHO they're a great
way to explore the libvirt API, especially combined with a nice OCaml
toplevel like utop-- so thanks for creating them!

-- 
Dave Scott
http://dave.recoil.org/
--
libvir-list mailing list
libvir-list@redhat.com
https://www.redhat.com/mailman/listinfo/libvir-list