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