mlvirtmanager/mlvirtmanager_connections.ml

   1 (* virt-manager-like graphical management tool.
   2    (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4 *)
   5
   6 open Printf
   7
   8 module C = Libvirt.Connect
   9 module D = Libvirt.Domain
  10 module N = Libvirt.Network
  11
  12 open Mlvirtmanager_helpers
  13
  14 (* List of currently open connections.  Actually it's a list of
  15  * (id, Libvirt.Connect.t) so that we can easily identify
  16  * connections by their unique ID.
  17  *)
  18 let get_conns, add_conn, del_conn =
  19   let conns = ref [] in
  20   let id = ref 0 in
  21   let get_conns () = !conns in
  22   let add_conn conn =
  23     incr id; let id = !id in
  24     conns := (id, conn) :: !conns;
  25     id
  26   in
  27   let del_conn id =
  28     conns := List.filter (fun (id', _) -> id <> id') !conns
  29   in
  30   get_conns, add_conn, del_conn
  31
  32 (* The current state.  This is used so that we can see changes that
  33  * have happened and add or remove parts of the model.  (Previously
  34  * we used to recreate the whole model each time, but the problem
  35  * with that is we "forget" things like the selection).
  36  *)
  37 type state = connection list
  38 and connection = int (* connection ID *) * (active list * inactive list)
  39 and active = int (* domain's ID *)
  40 and inactive = string (* domain's name *)
  41
  42 (* The last "CPU time" seen for a domain, so we can calculate CPU % usage.
  43  * Hash of (connid, domid) -> cpu_time [int64].
  44  *)
  45 let last_cpu_time = Hashtbl.create 13
  46 let last_time = ref (Unix.gettimeofday ())
  47
  48 type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column
  49
  50 let debug_repopulate = true
  51
  52 (* Populate the tree with the current list of connections, domains.
  53  * This function is called once per second.
  54  *)
  55 let repopulate (tree : GTree.view) (model : GTree.tree_store)
  56     (col_name_id, col_domname, col_status, col_cpu, col_mem, col_id)
  57     state =
  58   let time_passed =
  59     let time_now = Unix.gettimeofday () in
  60     let time_passed = time_now -. !last_time in
  61     last_time := time_now;
  62     time_passed in
  63
  64   (* Which connections have been added or removed? *)
  65   let conns = get_conns () in
  66   let added, _, removed =
  67     let old_conn_ids = List.map fst state
  68     and new_conn_ids = List.map fst conns in
  69     differences old_conn_ids new_conn_ids in
  70
  71   (* Remove the subtrees for any connections which have gone. *)
  72   if debug_repopulate then List.iter (eprintf "-connection %d\n%!") removed;
  73
  74   List.iter (
  75     fun conn_id ->
  76       filter_top_level_rows model
  77         (fun row -> conn_id <> model#get ~row ~column:col_id)
  78   ) removed;
  79
  80   (* Add placeholder subtree for any new connections. *)
  81   if debug_repopulate then List.iter (eprintf "+connection %d\n%!") added;
  82
  83   List.iter (
  84     fun conn_id ->
  85       let row = model#append () in
  86       (* Get the connection name. *)
  87       let name =
  88         try C.get_hostname (List.assoc conn_id conns)
  89         with Not_found | Libvirt.Virterror _ ->
  90           "Conn #" ^ string_of_int conn_id in
  91       model#set ~row ~column:col_name_id name;
  92       model#set ~row ~column:col_id conn_id;
  93       (* XXX This doesn't work, why? *)
  94       tree#expand_row (model#get_path row)
  95   ) added;
  96
  97   let new_state =
  98     List.map (
  99       fun (conn_id, conn) ->
 100         (* Get the old list of active and inactive domains.  If this
 101          * connection is newly created, start with empty lists.
 102          *)
 103         let old_active, old_inactive =
 104           try List.assoc conn_id state
 105           with Not_found -> [], [] in
 106
 107         (* Get the top level row in the model corresponding to this
 108          * connection.
 109          *)
 110         let parent =
 111           try find_top_level_row model
 112             (fun row -> conn_id = model#get ~row ~column:col_id)
 113           with Not_found -> assert false (* Should never happen. *) in
 114
 115         try
 116           (* Node info & number of CPUs available. *)
 117           let node_info = C.get_node_info conn in
 118           let nr_cpus = C.maxcpus_of_node_info node_info in
 119
 120           (* For this connection, get a current list of active domains (IDs) *)
 121           let active =
 122             let n = C.num_of_domains conn in
 123             let doms = C.list_domains conn n in
 124             Array.to_list doms in
 125
 126           (* Which active domains have been added or removed? *)
 127           let added, _, removed = differences old_active active in
 128
 129           (* Remove any active domains which have disappeared. *)
 130           if debug_repopulate then
 131             List.iter (eprintf "-active %d\n%!") removed;
 132
 133           List.iter (
 134             fun domid ->
 135               filter_rows model
 136                 (fun row -> domid <> model#get ~row ~column:col_id)
 137                 (model#iter_children (Some parent))
 138           ) removed;
 139
 140           (* Add any active domains which have appeared. *)
 141           if debug_repopulate then
 142             List.iter (eprintf "+active %d\n%!") added;
 143
 144           List.iter (
 145             fun domid ->
 146               let domname =
 147                 try
 148                   let dom = D.lookup_by_id conn domid in
 149                   D.get_name dom
 150                 with _ -> "" in (* Ignore any transient error. *)
 151
 152               let row = model#append ~parent () in
 153               model#set ~row ~column:col_name_id (string_of_int domid);
 154               model#set ~row ~column:col_domname domname;
 155               model#set ~row ~column:col_id domid
 156           ) added;
 157
 158           (* Get a current list of inactive domains (names). *)
 159           let inactive =
 160             let n = C.num_of_defined_domains conn in
 161             let doms = C.list_defined_domains conn n in
 162             Array.to_list doms in
 163
 164           (* Which inactive domains have been added or removed? *)
 165           let added, _, removed = differences old_inactive inactive in
 166
 167           (* Remove any inactive domains which have disappeared. *)
 168           if debug_repopulate then
 169             List.iter (eprintf "-inactive %s\n%!") removed;
 170
 171           List.iter (
 172             fun domname ->
 173               filter_rows model
 174                 (fun row ->
 175                    model#get ~row ~column:col_id <> -1 ||
 176                    model#get ~row ~column:col_domname <> domname)
 177                 (model#iter_children (Some parent))
 178           ) removed;
 179
 180           (* Add any inactive domains which have appeared. *)
 181           if debug_repopulate then
 182             List.iter (eprintf "+inactive %s\n%!") added;
 183
 184           List.iter (
 185             fun domname ->
 186               let row = model#append ~parent () in
 187               model#set ~row ~column:col_name_id "";
 188               model#set ~row ~column:col_domname domname;
 189               model#set ~row ~column:col_status "inactive";
 190               model#set ~row ~column:col_id (-1)
 191           ) added;
 192
 193           (* Now iterate over all active domains and update their state,
 194            * CPU and memory.
 195            *)
 196           iter_rows model (
 197             fun row ->
 198               let domid = model#get ~row ~column:col_id in
 199               if domid >= 0 then ( (* active *)
 200                 try
 201                   let dom = D.lookup_by_id conn domid in
 202                   let info = D.get_info dom in
 203                   let status = string_of_domain_state info.D.state in
 204                   model#set ~row ~column:col_status status;
 205                   let memory = sprintf "%Ld K" info.D.memory in
 206                   model#set ~row ~column:col_mem memory;
 207
 208                   let ns_now = info.D.cpu_time in (* ns = nanoseconds *)
 209                   let ns_prev =
 210                     try
 211                       let ns = Hashtbl.find last_cpu_time (conn_id, domid) in
 212                       if ns > ns_now then 0L else ns (* Rebooted? *)
 213                     with Not_found -> 0L in
 214                   Hashtbl.replace last_cpu_time (conn_id, domid) ns_now;
 215                   let ns_now = Int64.to_float ns_now in
 216                   let ns_prev = Int64.to_float ns_prev in
 217                   let ns_used = ns_now -. ns_prev in
 218                   let ns_available = 1_000_000_000. *. float nr_cpus in
 219                   let cpu_percent =
 220                     100. *. (ns_used /. ns_available) /. time_passed in
 221                   let cpu_percent = sprintf "%.1f %%" cpu_percent in
 222                   model#set ~row ~column:col_cpu cpu_percent;
 223
 224                 with Libvirt.Virterror _ -> () (* Ignore any transient error *)
 225               )
 226           ) (model#iter_children (Some parent));
 227
 228           (* Return new state. *)
 229           conn_id, (active, inactive)
 230         with
 231         (* Libvirt errors here are not really fatal.  They can happen
 232          * if the state changes at the moment we read it.  If it does
 233          * happen, just return the old state, and next time we come
 234          * around to this connection it'll be fixed.
 235          *)
 236         | Libvirt.Virterror err ->
 237             prerr_endline (Libvirt.Virterror.to_string err);
 238             conn_id, (old_active, old_inactive)
 239         | Failure msg ->
 240             prerr_endline msg;
 241             conn_id, (old_active, old_inactive)
 242     ) conns in
 243
 244   (* Return the updated state. *)
 245   new_state
 246
 247 (* Make the treeview which displays the connections and domains. *)
 248 let make_treeview ?packing () =
 249   let cols = new GTree.column_list in
 250   let col_name_id = cols#add Gobject.Data.string in
 251   let col_domname = cols#add Gobject.Data.string in
 252   let col_status = cols#add Gobject.Data.string in
 253   let col_cpu = cols#add Gobject.Data.string in
 254   let col_mem = cols#add Gobject.Data.string in
 255   (* Hidden column containing the connection ID or domain ID.  For
 256    * inactive domains, this contains -1 and col_domname is the name. *)
 257   let col_id = cols#add Gobject.Data.int in
 258   let model = GTree.tree_store cols in
 259
 260   (* Column sorting functions. *)
 261   let make_sort_func_on column =
 262     fun (model : GTree.model) row1 row2 ->
 263       let col1 = model#get ~row:row1 ~column in
 264       let col2 = model#get ~row:row2 ~column in
 265       compare col1 col2
 266   in
 267   (*model#set_default_sort_func (make_sort_func_on col_domname);*)
 268   model#set_sort_func 0 (make_sort_func_on col_name_id);
 269   model#set_sort_func 1 (make_sort_func_on col_domname);
 270   model#set_sort_column_id 1 `ASCENDING;
 271
 272   (* Make the GtkTreeView and attach column renderers to it. *)
 273   let tree = GTree.view ~model ~reorderable:false ?packing () in
 274
 275   let append_visible_column title column sort =
 276     let renderer = GTree.cell_renderer_text [], ["text", column] in
 277     let view_col = GTree.view_column ~title ~renderer () in
 278     ignore (tree#append_column view_col);
 279     match sort with
 280     | None -> ()
 281     | Some (sort_indicator, sort_order, sort_column_id) ->
 282         view_col#set_sort_indicator sort_indicator;
 283         view_col#set_sort_order sort_order;
 284         view_col#set_sort_column_id sort_column_id
 285   in
 286   append_visible_column "ID" col_name_id (Some (false, `ASCENDING, 0));
 287   append_visible_column "Name" col_domname (Some (true, `ASCENDING, 1));
 288   append_visible_column "Status" col_status None;
 289   append_visible_column "CPU" col_cpu None;
 290   append_visible_column "Memory" col_mem None;
 291
 292   let columns =
 293     col_name_id, col_domname, col_status, col_cpu, col_mem, col_id in
 294   let state = repopulate tree model columns [] in
 295
 296   (tree, model, columns, state)
 297
 298 (* Callback function to open a connection.
 299  * This should be a lot more sophisticated. XXX
 300  *)
 301 let open_connection () =
 302   let title = "Open connection to hypervisor" in
 303   let name =
 304     GToolbox.input_string ~title ~text:"xen:///" ~ok:"Open" "Connection:" in
 305   match name with
 306   | None -> ()
 307   | Some name ->
 308       (* If this fails, let the exception escape and be printed
 309        * in the global exception handler.
 310        *)
 311       let conn = C.connect ~name () in
 312       ignore (add_conn conn)