[libvirt] ocaml: prototype bindings for event callbacks
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
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.scott@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
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.scott@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 + | 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 -> unit = "ocaml_libvirt_event_register_any" + + 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; + register_any' conn dom callback id + +end + module Network = struct type 'rw t diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli index a106a64..d633794 100644 --- a/libvirt/libvirt.mli +++ b/libvirt/libvirt.mli @@ -645,6 +645,343 @@ 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. *) + + val register_any : 'a Connect.t -> ?dom:'a Domain.t -> callback -> unit + (** [register_any con ?dom callback] registers [callback] + to receive notification of arbitrary domain events. + + 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]. + *) + +end + (** Module dealing with events generated by domain + state changes. *) + (** {3 Networks} *) module Network : diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c index 7506ab0..06cd486 100644 --- a/libvirt/libvirt_c_oneoffs.c +++ b/libvirt/libvirt_c_oneoffs.c @@ -221,7 +221,6 @@ ocaml_libvirt_connect_set_keep_alive(value connv, #endif } - CAMLprim value ocaml_libvirt_domain_get_id (value domv) { @@ -914,6 +913,392 @@ ocaml_libvirt_domain_memory_peek_bytecode (value *argv, int argn) argv[3], argv[4], argv[5]); } +/*----------------------------------------------------------------------*/ + +/* Domain events */ + +#ifdef HAVE_WEAK_SYMBOLS +#ifdef HAVE_VIREVENTREGISTERDEFAULTIMPL +extern int virEventRegisterDefaultImpl () __attribute__((weak)); +#endif +#endif + +CAMLprim value +ocaml_libvirt_event_register_default_impl (value unitv) +{ + CAMLparam1 (unitv); +#ifndef HAVE_VIREVENTREGISTERDEFAULTIMPL + /* Symbol virEventRegisterDefaultImpl not found at compile time. */ + not_supported ("virEventRegisterDefaultImpl"); + CAMLnoreturn; +#else + /* Check that the symbol virEventRegisterDefaultImpl + * is in runtime version of libvirt. + */ + WEAK_SYMBOL_CHECK (virEventRegisterDefaultImpl); + + /* 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); +#endif +} + +#ifdef HAVE_WEAK_SYMBOLS +#ifdef HAVE_VIREVENTRUNDEFAULTIMPL +extern int virEventRunDefaultImpl () __attribute__((weak)); +#endif +#endif + +CAMLprim value +ocaml_libvirt_event_run_default_impl (value unitv) +{ + CAMLparam1 (unitv); +#ifndef HAVE_VIREVENTRUNDEFAULTIMPL + /* Symbol virEventRunDefaultImpl not found at compile time. */ + not_supported ("virEventRunDefaultImpl"); + CAMLnoreturn; +#else + /* Check that the symbol virEventRunDefaultImpl + * is in runtime version of libvirt. + */ + WEAK_SYMBOL_CHECK (virEventRunDefaultImpl); + + /* arg is of type unit = void */ + int r; + + NONBLOCKING (r = virEventRunDefaultImpl ()); + if (r == -1) caml_failwith("virEventRunDefaultImpl"); + + CAMLreturn (Val_unit); +#endif +} + +/* 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 CALLBACK_BEGIN(NAME) + where NAME is the string name of the OCaml callback registered + in libvirt.ml. */ +#define CALLBACK_BEGIN(NAME) \ + CAMLparam0(); \ + CAMLlocal4(connv, domv, callback_id, result); \ + 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) == 0) { \ + 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 CALLBACK_END \ + (void) caml_callback3(*callback, callback_id, domv, result); \ + } \ + caml_enter_blocking_section(); \ + CAMLreturn0; + + +static void +i_i_callback(virConnectPtr conn, + virDomainPtr dom, + int x, + int y, + void * opaque) +{ + 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)); + CALLBACK_END +} + +static void +u_callback(virConnectPtr conn, + virDomainPtr dom, + void *opaque) +{ + CALLBACK_BEGIN("Libvirt.u_callback") + result = Val_int(0); /* () */ + CALLBACK_END +} + +static void +i64_callback(virConnectPtr conn, + virDomainPtr dom, + long long int64, + void *opaque) +{ + CALLBACK_BEGIN("Libvirt.i64_callback") + result = caml_copy_int64(int64); + CALLBACK_END +} + +static void +i_callback(virConnectPtr conn, + virDomainPtr dom, + int x, + void *opaque) +{ + CALLBACK_BEGIN("Libvirt.i_callback") + result = Val_int(x); + CALLBACK_END +} + +static void +s_i_callback(virConnectPtr conn, + virDomainPtr dom, + char *x, + int y, + void * opaque) +{ + 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)); + CALLBACK_END +} + +static void +s_i_i_callback(virConnectPtr conn, + virDomainPtr dom, + char *x, + int y, + int z, + void * opaque) +{ + 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)); + CALLBACK_END +} + +static void +s_s_i_callback(virConnectPtr conn, + virDomainPtr dom, + char *x, + char *y, + int z, + void *opaque) +{ + 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)); + CALLBACK_END +} + +static void +s_s_i_s_callback(virConnectPtr conn, + virDomainPtr dom, + char *x, + char *y, + int z, + char *a, + void *opaque) +{ + 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)); + CALLBACK_END +} + +static void +s_s_s_i_callback(virConnectPtr conn, + virDomainPtr dom, + char * x, + char * y, + char * z, + int a, + void * opaque) +{ + 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)); + 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) +{ + 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)); + CALLBACK_END +} + +CAMLprim value +ocaml_libvirt_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, conn, "virConnectDomainEventRegisterAny"); + + CAMLreturn(Val_unit); +} + #ifdef HAVE_WEAK_SYMBOLS #ifdef HAVE_VIRSTORAGEPOOLGETINFO extern int virStoragePoolGetInfo(virStoragePoolPtr pool, virStoragePoolInfoPtr info) -- 1.7.10.4
Signed-off-by: David Scott <dave.scott@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 0000000..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 (E.RtcChange (fun dom e -> + printd dom "RtcChange %s" (E.Rtc_change.to_string e) + )); + E.register_any conn (E.Watchdog (fun dom e -> + printd dom "Watchdog %s" (E.Watchdog.to_string e) + )); + E.register_any conn (E.IOError (fun dom e -> + printd dom "IOError %s" (E.Io_error.to_string e) + )); + E.register_any conn (E.IOErrorReason (fun dom e -> + printd dom "IOErrorReason %s" (E.Io_error.to_string e) + )); + E.register_any conn (E.Graphics (fun dom e -> + printd dom "Graphics %s" (E.Graphics.to_string e) + )); + E.register_any conn (E.ControlError (fun dom e -> + printd dom "ControlError %s" (E.Control_error.to_string e) + )); + E.register_any conn (E.BlockJob (fun dom e -> + printd dom "BlockJob %s" (E.Block_job.to_string e) + )); + E.register_any conn (E.DiskChange (fun dom e -> + printd dom "DiskChange %s" (E.Disk_change.to_string e) + )); + E.register_any conn (E.TrayChange (fun dom e -> + printd dom "TrayChange %s" (E.Tray_change.to_string e) + )); + E.register_any conn (E.PMWakeUp (fun dom e -> + printd dom "PMWakeup %s" (E.PM_wakeup.to_string e) + )); + E.register_any conn (E.PMSuspend (fun dom e -> + printd dom "PMSuspend %s" (E.PM_suspend.to_string e) + )); + E.register_any conn (E.BalloonChange (fun dom e -> + printd dom "BalloonChange %s" (E.Balloon_change.to_string e) + )); + E.register_any conn (E.PMSuspendDisk (fun dom x -> + printd dom "PMSuspendDisk %s" (E.PM_suspend_disk.to_string x) + )); + C.set_keep_alive conn 5 3; + while true do + E.run_default_impl () + done + with + Libvirt.Virterror err -> + eprintf "error: %s\n" (Libvirt.Virterror.to_string err) + +let () = + (* Run the garbage collector which is a good way to check for + * memory corruption errors and reference counting issues in libvirt. + *) + Gc.compact () -- 1.7.10.4
On Wed, Mar 27, 2013 at 04:59:29PM +0000, David Scott wrote:
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!
I looked over this, and it all looks pretty sensible to me. Let me know when you're ready to have a patch applied upstream. The one comment I would make (which is not related directly to your patch, but would make it simpler) is that we ought to change the minimum supported version of libvirt from whatever it is now (0.2.1?) to some much more recent version. I don't think anyone would care if ocaml-libvirt only worked with, say, libvirt >= 0.9.1 which was released in May 2011. Rich. -- Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones Fedora Windows cross-compiler. Compile Windows programs, test, and build Windows installers. Over 100 libraries supported. http://fedoraproject.org/wiki/MinGW
participants (2)
-
David Scott -
Richard W.M. Jones