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(a)eu.citrix.com&gt; --- 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