examples/domain_events.ml

   1 (* Simple demo program showing how to receive domain events.
   2    Usage: domain_events [URI]
   3    (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
   4    (C) Copyright 2013 Citrix Inc
   5    https://libvirt.org/
   6  *)
   7
   8 open Printf
   9
  10 module C = Libvirt.Connect
  11 module D = Libvirt.Domain
  12 module E = Libvirt.Event
  13 module N = Libvirt.Network
  14
  15 let string_of_state = function
  16   | D.InfoNoState -> "no state"
  17   | D.InfoRunning -> "running"
  18   | D.InfoBlocked -> "blocked"
  19   | D.InfoPaused -> "paused"
  20   | D.InfoShutdown -> "shutdown"
  21   | D.InfoShutoff -> "shutoff"
  22   | D.InfoCrashed -> "crashed"
  23   | D.InfoPMSuspended -> "pm suspended"
  24
  25 let printd dom fmt =
  26   let prefix dom =
  27     let id = D.get_id dom in
  28     try
  29       let name = D.get_name dom in
  30       let info = D.get_info dom in
  31       let state = string_of_state info.D.state in
  32       sprintf "%8d %-20s %s " id name state
  33   with _ ->
  34       sprintf "%8d " id in
  35   let write x =
  36     output_string stdout (prefix dom);
  37     output_string stdout x;
  38     output_string stdout "\n";
  39     flush stdout in
  40   Printf.ksprintf write fmt
  41
  42 let string_option = function
  43   | None -> "None"
  44   | Some x -> "Some " ^ x
  45
  46 let string_of_graphics_address (family, node, service) =
  47   Printf.sprintf "{ family=%d; node=%s; service=%s }" family (string_option node) (string_option service)
  48
  49 let string_of_graphics_subject_identity (ty, name) =
  50   Printf.sprintf "{ type=%s; name=%s }" (string_option ty) (string_option name)
  51
  52 let string_of_graphics_subject xs = String.concat "; " (List.map string_of_graphics_subject_identity (Array.to_list xs))
  53
  54 let map_option f = function
  55   | None -> None
  56   | Some x -> Some (f x)
  57
  58 let () =
  59   try
  60     E.register_default_impl ();
  61     let name =
  62       if Array.length Sys.argv >= 2 then
  63         Some (Sys.argv.(1))
  64       else
  65         None in
  66     let conn = C.connect_auth_readonly ?name (C.get_auth_default ()) in
  67
  68     let spinner = [| '|'; '/'; '-'; '\\' |] in
  69
  70     let timeouts = ref 0 in
  71     (* Check add/remove works *)
  72     let id = E.add_timeout conn 250 (fun () -> Printf.printf "This callback is immediately deregistered\n%!") in
  73     E.remove_timeout conn id;
  74
  75     let (_: E.timer_id) = E.add_timeout conn 250 (* ms *)
  76         (fun () ->
  77             incr timeouts;
  78             Printf.printf "\r%c  %d timeout callbacks%!" (spinner.(!timeouts mod (Array.length spinner))) !timeouts;
  79             (* Check for GC errors: *)
  80             Gc.compact ()
  81         ) in
  82
  83     (* Check add/remove works *)
  84     let id = E.register_any conn (E.Lifecycle (fun dom e ->
  85         printd dom "Removed Lifecycle callback %s" (E.Lifecycle.to_string e)
  86     )) in
  87     E.deregister_any conn id;
  88
  89     let (_: E.callback_id) = E.register_any conn (E.Lifecycle (fun dom e ->
  90         printd dom "Lifecycle %s" (E.Lifecycle.to_string e)
  91     )) in
  92     let (_: E.callback_id) = E.register_any conn (E.Reboot (fun dom e ->
  93         printd dom "Reboot %s" (E.Reboot.to_string e)
  94     )) in
  95     let (_: E.callback_id) = E.register_any conn (E.RtcChange (fun dom e ->
  96         printd dom "RtcChange %s" (E.Rtc_change.to_string e)
  97     )) in
  98     let (_: E.callback_id) = E.register_any conn (E.Watchdog (fun dom e ->
  99         printd dom "Watchdog %s" (E.Watchdog.to_string e)
 100     )) in
 101     let (_: E.callback_id) = E.register_any conn (E.IOError (fun dom e ->
 102         printd dom "IOError %s" (E.Io_error.to_string e)
 103     )) in
 104     let (_: E.callback_id) = E.register_any conn (E.IOErrorReason (fun dom e ->
 105         printd dom "IOErrorReason %s" (E.Io_error.to_string e)
 106     )) in
 107     let (_: E.callback_id) = E.register_any conn (E.Graphics (fun dom e ->
 108         printd dom "Graphics %s" (E.Graphics.to_string e)
 109     )) in
 110     let (_: E.callback_id) = E.register_any conn (E.ControlError (fun dom e ->
 111         printd dom "ControlError %s" (E.Control_error.to_string e)
 112     )) in
 113     let (_: E.callback_id) = E.register_any conn (E.BlockJob (fun dom e ->
 114         printd dom "BlockJob %s" (E.Block_job.to_string e)
 115     )) in
 116     let (_: E.callback_id) = E.register_any conn (E.DiskChange (fun dom e ->
 117         printd dom "DiskChange %s" (E.Disk_change.to_string e)
 118     )) in
 119     let (_: E.callback_id) = E.register_any conn (E.TrayChange (fun dom e ->
 120         printd dom "TrayChange %s" (E.Tray_change.to_string e)
 121     )) in
 122     let (_: E.callback_id) = E.register_any conn (E.PMWakeUp (fun dom e ->
 123         printd dom "PMWakeup %s" (E.PM_wakeup.to_string e)
 124     )) in
 125     let (_: E.callback_id) = E.register_any conn (E.PMSuspend (fun dom e ->
 126         printd dom "PMSuspend %s" (E.PM_suspend.to_string e)
 127     )) in
 128     let (_: E.callback_id) = E.register_any conn (E.BalloonChange (fun dom e ->
 129         printd dom "BalloonChange %s" (E.Balloon_change.to_string e)
 130     )) in
 131     let (_: E.callback_id) = E.register_any conn (E.PMSuspendDisk (fun dom x ->
 132         printd dom "PMSuspendDisk %s" (E.PM_suspend_disk.to_string x)
 133     )) in
 134     C.set_keep_alive conn 5 3;
 135     while true do
 136         E.run_default_impl ()
 137     done
 138   with
 139     Libvirt.Virterror err ->
 140       eprintf "error: %s\n" (Libvirt.Virterror.to_string err)
 141
 142 let () =
 143   (* Run the garbage collector which is a good way to check for
 144    * memory corruption errors and reference counting issues in libvirt.
 145    *)
 146   Gc.compact ()