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