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