virt-ctrl/vc_connections.ml

   1 (* virt-ctrl: A 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 Vc_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 (* Store the node_info and hostname for each connection, fetched
  63  * once just after we connect since these don't normally change.
  64  * Hash of connid -> (C.node_info, hostname option, uri)
  65  *)
  66 let static_conn_info = Hashtbl.create 13
  67
  68 type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column
  69
  70 let debug_repopulate = true
  71
  72 (* Populate the tree with the current list of connections, domains.
  73  * This function is called once per second.
  74  *)
  75 let repopulate (tree : GTree.view) (model : GTree.tree_store)
  76     (col_name_id, col_domname, col_status, col_cpu, col_mem, col_id)
  77     state =
  78   let time_passed =
  79     let time_now = Unix.gettimeofday () in
  80     let time_passed = time_now -. !last_time in
  81     last_time := time_now;
  82     time_passed in
  83
  84   (* Which connections have been added or removed? *)
  85   let conns = get_conns () in
  86   let added, _, removed =
  87     let old_conn_ids = List.map fst state
  88     and new_conn_ids = List.map fst conns in
  89     differences old_conn_ids new_conn_ids in
  90
  91   (* Remove the subtrees for any connections which have gone. *)
  92   if debug_repopulate then List.iter (eprintf "-connection %d\n%!") removed;
  93
  94   List.iter (
  95     fun conn_id ->
  96       filter_top_level_rows model
  97         (fun row -> conn_id <> model#get ~row ~column:col_id)
  98   ) removed;
  99
 100   (* Add placeholder subtree for any new connections. *)
 101   if debug_repopulate then List.iter (eprintf "+connection %d\n%!") added;
 102
 103   List.iter (
 104     fun conn_id ->
 105       let row = model#append () in
 106       (* Get the connection name, usually the hostname. *)
 107       let name =
 108         match Hashtbl.find static_conn_info conn_id with
 109         | (_, Some hostname, _) -> hostname
 110         | (_, None, _) -> sprintf "Conn #%d" conn_id in
 111       model#set ~row ~column:col_name_id name;
 112       model#set ~row ~column:col_id conn_id;
 113       (* Expand the new row. *)
 114       (* XXX This doesn't work, why? - Because we haven't create subrows yet.*)
 115       tree#expand_row (model#get_path row)
 116   ) added;
 117
 118   let new_state =
 119     List.map (
 120       fun (conn_id, conn) ->
 121         (* Get the old list of active and inactive domains.  If this
 122          * connection is newly created, start with empty lists.
 123          *)
 124         let old_active, old_inactive =
 125           try List.assoc conn_id state
 126           with Not_found -> [], [] in
 127
 128         (* Get the top level row in the model corresponding to this
 129          * connection.
 130          *)
 131         let parent =
 132           try find_top_level_row model
 133             (fun row -> conn_id = model#get ~row ~column:col_id)
 134           with Not_found -> assert false (* Should never happen. *) in
 135
 136         try
 137           (* Number of CPUs available. *)
 138           let node_info, _, _ = Hashtbl.find static_conn_info conn_id in
 139           let nr_cpus = C.maxcpus_of_node_info node_info in
 140
 141           (* For this connection, get a current list of active domains (IDs) *)
 142           let active =
 143             let n = C.num_of_domains conn in
 144             let doms = C.list_domains conn n in
 145             Array.to_list doms in
 146
 147           (* Which active domains have been added or removed? *)
 148           let added, _, removed = differences old_active active in
 149
 150           (* Remove any active domains which have disappeared. *)
 151           if debug_repopulate then
 152             List.iter (eprintf "-active %d\n%!") removed;
 153
 154           List.iter (
 155             fun domid ->
 156               filter_rows model
 157                 (fun row -> domid <> model#get ~row ~column:col_id)
 158                 (model#iter_children (Some parent))
 159           ) removed;
 160
 161           (* Add any active domains which have appeared. *)
 162           if debug_repopulate then
 163             List.iter (eprintf "+active %d\n%!") added;
 164
 165           List.iter (
 166             fun domid ->
 167               let domname =
 168                 try
 169                   let dom = D.lookup_by_id conn domid in
 170                   D.get_name dom
 171                 with _ -> "" in (* Ignore any transient error. *)
 172
 173               let row = model#append ~parent () in
 174               model#set ~row ~column:col_name_id (string_of_int domid);
 175               model#set ~row ~column:col_domname domname;
 176               model#set ~row ~column:col_id domid
 177           ) added;
 178
 179           (* Get a current list of inactive domains (names). *)
 180           let inactive =
 181             let n = C.num_of_defined_domains conn in
 182             let doms = C.list_defined_domains conn n in
 183             Array.to_list doms in
 184
 185           (* Which inactive domains have been added or removed? *)
 186           let added, _, removed = differences old_inactive inactive in
 187
 188           (* Remove any inactive domains which have disappeared. *)
 189           if debug_repopulate then
 190             List.iter (eprintf "-inactive %s\n%!") removed;
 191
 192           List.iter (
 193             fun domname ->
 194               filter_rows model
 195                 (fun row ->
 196                    model#get ~row ~column:col_id <> -1 ||
 197                    model#get ~row ~column:col_domname <> domname)
 198                 (model#iter_children (Some parent))
 199           ) removed;
 200
 201           (* Add any inactive domains which have appeared. *)
 202           if debug_repopulate then
 203             List.iter (eprintf "+inactive %s\n%!") added;
 204
 205           List.iter (
 206             fun domname ->
 207               let row = model#append ~parent () in
 208               model#set ~row ~column:col_name_id "";
 209               model#set ~row ~column:col_domname domname;
 210               model#set ~row ~column:col_status "inactive";
 211               model#set ~row ~column:col_id (-1)
 212           ) added;
 213
 214           (* Now iterate over all active domains and update their state,
 215            * CPU and memory.
 216            *)
 217           iter_rows model (
 218             fun row ->
 219               let domid = model#get ~row ~column:col_id in
 220               if domid >= 0 then ( (* active *)
 221                 try
 222                   let dom = D.lookup_by_id conn domid in
 223                   let info = D.get_info dom in
 224                   let status = string_of_domain_state info.D.state in
 225                   model#set ~row ~column:col_status status;
 226                   let memory = sprintf "%Ld K" info.D.memory in
 227                   model#set ~row ~column:col_mem memory;
 228
 229                   let ns_now = info.D.cpu_time in (* ns = nanoseconds *)
 230                   let ns_prev =
 231                     try
 232                       let ns = Hashtbl.find last_cpu_time (conn_id, domid) in
 233                       if ns > ns_now then 0L else ns (* Rebooted? *)
 234                     with Not_found -> 0L in
 235                   Hashtbl.replace last_cpu_time (conn_id, domid) ns_now;
 236                   let ns_now = Int64.to_float ns_now in
 237                   let ns_prev = Int64.to_float ns_prev in
 238                   let ns_used = ns_now -. ns_prev in
 239                   let ns_available = 1_000_000_000. *. float nr_cpus in
 240                   let cpu_percent =
 241                     100. *. (ns_used /. ns_available) /. time_passed in
 242                   let cpu_percent = sprintf "%.1f %%" cpu_percent in
 243                   model#set ~row ~column:col_cpu cpu_percent;
 244
 245                 with Libvirt.Virterror _ -> () (* Ignore any transient error *)
 246               )
 247           ) (model#iter_children (Some parent));
 248
 249           (* Return new state. *)
 250           conn_id, (active, inactive)
 251         with
 252         (* Libvirt errors here are not really fatal.  They can happen
 253          * if the state changes at the moment we read it.  If it does
 254          * happen, just return the old state, and next time we come
 255          * around to this connection it'll be fixed.
 256          *)
 257         | Libvirt.Virterror err ->
 258             prerr_endline (Libvirt.Virterror.to_string err);
 259             conn_id, (old_active, old_inactive)
 260         | Failure msg ->
 261             prerr_endline msg;
 262             conn_id, (old_active, old_inactive)
 263     ) conns in
 264
 265   (* Return the updated state. *)
 266   new_state
 267
 268 (* Make the treeview which displays the connections and domains. *)
 269 let make_treeview ?packing () =
 270   let cols = new GTree.column_list in
 271   let col_name_id = cols#add Gobject.Data.string in
 272   let col_domname = cols#add Gobject.Data.string in
 273   let col_status = cols#add Gobject.Data.string in
 274   let col_cpu = cols#add Gobject.Data.string in
 275   let col_mem = cols#add Gobject.Data.string in
 276   (* Hidden column containing the connection ID or domain ID.  For
 277    * inactive domains, this contains -1 and col_domname is the name. *)
 278   let col_id = cols#add Gobject.Data.int in
 279   let model = GTree.tree_store cols in
 280
 281   (* Column sorting functions. *)
 282   let make_sort_func_on column =
 283     fun (model : GTree.model) row1 row2 ->
 284       let col1 = model#get ~row:row1 ~column in
 285       let col2 = model#get ~row:row2 ~column in
 286       compare col1 col2
 287   in
 288   (*model#set_default_sort_func (make_sort_func_on col_domname);*)
 289   model#set_sort_func 0 (make_sort_func_on col_name_id);
 290   model#set_sort_func 1 (make_sort_func_on col_domname);
 291   model#set_sort_column_id 1 `ASCENDING;
 292
 293   (* Make the GtkTreeView and attach column renderers to it. *)
 294   let tree = GTree.view ~model ~reorderable:false ?packing () in
 295
 296   let append_visible_column title column sort =
 297     let renderer = GTree.cell_renderer_text [], ["text", column] in
 298     let view_col = GTree.view_column ~title ~renderer () in
 299     ignore (tree#append_column view_col);
 300     match sort with
 301     | None -> ()
 302     | Some (sort_indicator, sort_order, sort_column_id) ->
 303         view_col#set_sort_indicator sort_indicator;
 304         view_col#set_sort_order sort_order;
 305         view_col#set_sort_column_id sort_column_id
 306   in
 307   append_visible_column "ID" col_name_id (Some (false, `ASCENDING, 0));
 308   append_visible_column "Name" col_domname (Some (true, `ASCENDING, 1));
 309   append_visible_column "Status" col_status None;
 310   append_visible_column "CPU" col_cpu None;
 311   append_visible_column "Memory" col_mem None;
 312
 313   let columns =
 314     col_name_id, col_domname, col_status, col_cpu, col_mem, col_id in
 315   let state = repopulate tree model columns [] in
 316
 317   (tree, model, columns, state)
 318
 319 (* Callback function to open a connection.
 320  * This should be a lot more sophisticated. XXX
 321  *)
 322 let open_connection () =
 323   let title = "Open connection to hypervisor" in
 324   let uri =
 325     GToolbox.input_string ~title ~text:"xen:///" ~ok:"Open" "Connection:" in
 326   match uri with
 327   | None -> ()
 328   | Some uri ->
 329       (* If this fails, let the exception escape and be printed
 330        * in the global exception handler.
 331        *)
 332       let conn = C.connect ~name:uri () in
 333
 334       let node_info = C.get_node_info conn in
 335       let hostname =
 336         try Some (C.get_hostname conn)
 337         with
 338         | Libvirt.Not_supported "virConnectGetHostname"
 339         | Libvirt.Virterror _ -> None in
 340
 341       (* Add it to our list of connections. *)
 342       let conn_id = add_conn conn in
 343       Hashtbl.add static_conn_info conn_id (node_info, hostname, uri)