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 (* Store the node_info and hostname for each connection, fetched
  57  * once just after we connect since these don't normally change.
  58  * Hash of connid -> (C.node_info, hostname option, uri)
  59  *)
  60 let static_conn_info = Hashtbl.create 13
  61
  62 (* Stores the state and history for each domain.
  63  * Hash of (connid, domid) -> mutable domhistory structure.
  64  * We never delete entries in this hash table, which may be a problem
  65  * for very very long-lived instances of virt-ctrl.
  66  *)
  67 type domhistory = {
  68   (* for %CPU calculation: *)
  69   mutable last_cpu_time : int64;        (* last virDomainInfo->cpuTime *)
  70   mutable last_time : float;            (* exact time we measured the above *)
  71
  72   (* historical data for graphs etc: *)
  73   mutable hist_cpu : int array;         (* historical %CPU *)
  74   mutable hist_cpu_posn : int;          (* position within array *)
  75   mutable hist_mem : int64 array;       (* historical memory (kilobytes) *)
  76   mutable hist_mem_posn : int;          (* position within array *)
  77 }
  78
  79 let domhistory = Hashtbl.create 13
  80
  81 let new_domhistory () = {
  82   last_cpu_time = 0L; last_time = 0.;
  83   hist_cpu = Array.make 0 0; hist_cpu_posn = 0;
  84   hist_mem = Array.make 0 0L; hist_mem_posn = 0;
  85 }
  86
  87 (* These set limits on the amount of history we collect. *)
  88 let hist_max = 86400                    (* max history stored, seconds *)
  89 let hist_rot = 3600                     (* rotation of array when we hit max *)
  90
  91 (* The types of the display columns in the main window.  The interesting
  92  * one of the final (int) field which stores the ID of the row, either
  93  * connid or domid.
  94  *)
  95 type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column
  96
  97 let debug_repopulate = true
  98
  99 (* Populate the tree with the current list of connections, domains.
 100  * This function is called once per second.
 101  *)
 102 let repopulate (tree : GTree.view) (model : GTree.tree_store)
 103     (col_name_id, col_domname, col_status, col_cpu, col_mem, col_id)
 104     state =
 105   (* Which connections have been added or removed? *)
 106   let conns = get_conns () in
 107   let added, _, removed =
 108     let old_conn_ids = List.map fst state
 109     and new_conn_ids = List.map fst conns in
 110     differences old_conn_ids new_conn_ids in
 111
 112   (* Remove the subtrees for any connections which have gone. *)
 113   if debug_repopulate then List.iter (eprintf "-connection %d\n%!") removed;
 114
 115   List.iter (
 116     fun conn_id ->
 117       filter_top_level_rows model
 118         (fun row -> conn_id <> model#get ~row ~column:col_id)
 119   ) removed;
 120
 121   (* Add placeholder subtree for any new connections. *)
 122   if debug_repopulate then List.iter (eprintf "+connection %d\n%!") added;
 123
 124   List.iter (
 125     fun conn_id ->
 126       let row = model#append () in
 127       (* Get the connection name, usually the hostname. *)
 128       let name =
 129         match Hashtbl.find static_conn_info conn_id with
 130         | (_, Some hostname, _) -> hostname
 131         | (_, None, _) -> sprintf "Conn #%d" conn_id in
 132       model#set ~row ~column:col_name_id name;
 133       model#set ~row ~column:col_id conn_id;
 134       (* Expand the new row. *)
 135       (* XXX This doesn't work, why? - Because we haven't create subrows yet.*)
 136       tree#expand_row (model#get_path row)
 137   ) added;
 138
 139   let new_state =
 140     List.map (
 141       fun (conn_id, conn) ->
 142         (* Get the old list of active and inactive domains.  If this
 143          * connection is newly created, start with empty lists.
 144          *)
 145         let old_active, old_inactive =
 146           try List.assoc conn_id state
 147           with Not_found -> [], [] in
 148
 149         (* Get the top level row in the model corresponding to this
 150          * connection.
 151          *)
 152         let parent =
 153           try find_top_level_row model
 154             (fun row -> conn_id = model#get ~row ~column:col_id)
 155           with Not_found -> assert false (* Should never happen. *) in
 156
 157         try
 158           (* Number of CPUs available. *)
 159           let node_info, _, _ = Hashtbl.find static_conn_info conn_id in
 160           let nr_cpus = C.maxcpus_of_node_info node_info in
 161
 162           (* For this connection, get a current list of active domains (IDs) *)
 163           let active =
 164             let n = C.num_of_domains conn in
 165             let doms = C.list_domains conn n in
 166             Array.to_list doms in
 167
 168           (* Which active domains have been added or removed? *)
 169           let added, _, removed = differences old_active active in
 170
 171           (* Remove any active domains which have disappeared. *)
 172           if debug_repopulate then
 173             List.iter (eprintf "-active %d\n%!") removed;
 174
 175           List.iter (
 176             fun domid ->
 177               filter_rows model
 178                 (fun row -> domid <> model#get ~row ~column:col_id)
 179                 (model#iter_children (Some parent))
 180           ) removed;
 181
 182           (* Add any active domains which have appeared. *)
 183           if debug_repopulate then
 184             List.iter (eprintf "+active %d\n%!") added;
 185
 186           List.iter (
 187             fun domid ->
 188               let domname =
 189                 try
 190                   let dom = D.lookup_by_id conn domid in
 191                   D.get_name dom
 192                 with _ -> "" in (* Ignore any transient error. *)
 193
 194               let row = model#append ~parent () in
 195               model#set ~row ~column:col_name_id (string_of_int domid);
 196               model#set ~row ~column:col_domname domname;
 197               model#set ~row ~column:col_id domid
 198           ) added;
 199
 200           (* Get a current list of inactive domains (names). *)
 201           let inactive =
 202             let n = C.num_of_defined_domains conn in
 203             let doms = C.list_defined_domains conn n in
 204             Array.to_list doms in
 205
 206           (* Which inactive domains have been added or removed? *)
 207           let added, _, removed = differences old_inactive inactive in
 208
 209           (* Remove any inactive domains which have disappeared. *)
 210           if debug_repopulate then
 211             List.iter (eprintf "-inactive %s\n%!") removed;
 212
 213           List.iter (
 214             fun domname ->
 215               filter_rows model
 216                 (fun row ->
 217                    model#get ~row ~column:col_id <> -1 ||
 218                    model#get ~row ~column:col_domname <> domname)
 219                 (model#iter_children (Some parent))
 220           ) removed;
 221
 222           (* Add any inactive domains which have appeared. *)
 223           if debug_repopulate then
 224             List.iter (eprintf "+inactive %s\n%!") added;
 225
 226           List.iter (
 227             fun domname ->
 228               let row = model#append ~parent () in
 229               model#set ~row ~column:col_name_id "";
 230               model#set ~row ~column:col_domname domname;
 231               model#set ~row ~column:col_status "inactive";
 232               model#set ~row ~column:col_id (-1)
 233           ) added;
 234
 235           (* Now iterate over all active domains and update their state,
 236            * CPU and memory.
 237            *)
 238           iter_rows model (
 239             fun row ->
 240               let domid = model#get ~row ~column:col_id in
 241               if domid >= 0 then ( (* active *)
 242                 try
 243                   let dom = D.lookup_by_id conn domid in
 244                   let info = D.get_info dom in
 245                   let status = string_of_domain_state info.D.state in
 246                   model#set ~row ~column:col_status status;
 247                   let memory = sprintf "%Ld K" info.D.memory in
 248                   model#set ~row ~column:col_mem memory;
 249
 250                   (* Get domhistory.  For a new domain it won't exist, so
 251                    * create an empty one.
 252                    *)
 253                   let dh =
 254                     let key = conn_id, domid in
 255                     try Hashtbl.find domhistory key
 256                     with Not_found ->
 257                       let dh = new_domhistory () in
 258                       Hashtbl.add domhistory key dh;
 259                       dh in
 260
 261                   (* Measure current time and domain cpuTime as close
 262                    * together as possible.
 263                    *)
 264                   let time_now = Unix.gettimeofday () in
 265                   let cpu_now = info.D.cpu_time in
 266
 267                   let time_prev = dh.last_time in
 268                   let cpu_prev =
 269                     if dh.last_cpu_time > cpu_now then 0L (* Rebooted? *)
 270                     else dh.last_cpu_time in
 271
 272                   dh.last_time <- time_now;
 273                   dh.last_cpu_time <- cpu_now;
 274
 275                   let cpu_percent =
 276                     if time_prev > 0. then (
 277                       let cpu_now = Int64.to_float cpu_now in
 278                       let cpu_prev = Int64.to_float cpu_prev in
 279                       let cpu_used = cpu_now -. cpu_prev in
 280                       let cpu_available = 1_000_000_000. *. float nr_cpus in
 281                       let time_passed = time_now -. time_prev in
 282
 283                       let cpu_percent =
 284                         100. *. (cpu_used /. cpu_available) /. time_passed in
 285
 286                       let cpu_percent_str = sprintf "%.1f %%" cpu_percent in
 287                       model#set ~row ~column:col_cpu cpu_percent_str;
 288                       int_of_float cpu_percent
 289                     ) else -1 in
 290
 291                   (* Store history. *)
 292                   let store arr posn datum =
 293                     if posn >= hist_max then (
 294                       (* rotate the array *)
 295                       Array.blit arr hist_rot arr 0 (hist_max - hist_rot);
 296                       let posn = posn - hist_rot in
 297                       arr.(posn) <- datum;
 298                       (arr, posn+1)
 299                     ) else (
 300                       let len = Array.length arr in
 301                       if posn < len then (
 302                         (* normal update *)
 303                         arr.(posn) <- datum;
 304                         (arr, posn+1)
 305                       ) else (
 306                         (* extend the array *)
 307                         let len' = min (max (2*len) 1) hist_max in
 308                         let arr' = Array.make len' datum in
 309                         Array.blit arr 0 arr' 0 len;
 310                         (arr', posn+1)
 311                       )
 312                     )
 313                   in
 314                   let hist_cpu, hist_cpu_posn =
 315                     store dh.hist_cpu dh.hist_cpu_posn cpu_percent in
 316                   dh.hist_cpu <- hist_cpu; dh.hist_cpu_posn <- hist_cpu_posn;
 317                   let hist_mem, hist_mem_posn =
 318                     store dh.hist_mem dh.hist_mem_posn info.D.memory in
 319                   dh.hist_mem <- hist_mem; dh.hist_mem_posn <- hist_mem_posn
 320
 321                 with
 322                   Libvirt.Virterror _ -> () (* Ignore any transient error *)
 323               )
 324           ) (model#iter_children (Some parent));
 325
 326           (* Return new state. *)
 327           conn_id, (active, inactive)
 328         with
 329         (* Libvirt errors here are not really fatal.  They can happen
 330          * if the state changes at the moment we read it.  If it does
 331          * happen, just return the old state, and next time we come
 332          * around to this connection it'll be fixed.
 333          *)
 334         | Libvirt.Virterror err ->
 335             prerr_endline (Libvirt.Virterror.to_string err);
 336             conn_id, (old_active, old_inactive)
 337         | Failure msg ->
 338             prerr_endline msg;
 339             conn_id, (old_active, old_inactive)
 340     ) conns in
 341
 342   (* Return the updated state. *)
 343   new_state
 344
 345 (* Make the treeview which displays the connections and domains. *)
 346 let make_treeview ?packing () =
 347   let cols = new GTree.column_list in
 348   let col_name_id = cols#add Gobject.Data.string in
 349   let col_domname = cols#add Gobject.Data.string in
 350   let col_status = cols#add Gobject.Data.string in
 351   let col_cpu = cols#add Gobject.Data.string in
 352   let col_mem = cols#add Gobject.Data.string in
 353   (* Hidden column containing the connection ID or domain ID.  For
 354    * inactive domains, this contains -1 and col_domname is the name. *)
 355   let col_id = cols#add Gobject.Data.int in
 356   let model = GTree.tree_store cols in
 357
 358   (* Column sorting functions. *)
 359   let make_sort_func_on column =
 360     fun (model : GTree.model) row1 row2 ->
 361       let col1 = model#get ~row:row1 ~column in
 362       let col2 = model#get ~row:row2 ~column in
 363       compare col1 col2
 364   in
 365   (*model#set_default_sort_func (make_sort_func_on col_domname);*)
 366   model#set_sort_func 0 (make_sort_func_on col_name_id);
 367   model#set_sort_func 1 (make_sort_func_on col_domname);
 368   model#set_sort_column_id 1 `ASCENDING;
 369
 370   (* Make the GtkTreeView and attach column renderers to it. *)
 371   let tree = GTree.view ~model ~reorderable:false ?packing () in
 372
 373   let append_visible_column title column sort =
 374     let renderer = GTree.cell_renderer_text [], ["text", column] in
 375     let view_col = GTree.view_column ~title ~renderer () in
 376     ignore (tree#append_column view_col);
 377     match sort with
 378     | None -> ()
 379     | Some (sort_indicator, sort_order, sort_column_id) ->
 380         view_col#set_sort_indicator sort_indicator;
 381         view_col#set_sort_order sort_order;
 382         view_col#set_sort_column_id sort_column_id
 383   in
 384   append_visible_column "ID" col_name_id (Some (false, `ASCENDING, 0));
 385   append_visible_column "Name" col_domname (Some (true, `ASCENDING, 1));
 386   append_visible_column "Status" col_status None;
 387   append_visible_column "CPU" col_cpu None;
 388   append_visible_column "Memory" col_mem None;
 389
 390   let columns =
 391     col_name_id, col_domname, col_status, col_cpu, col_mem, col_id in
 392   let state = repopulate tree model columns [] in
 393
 394   (tree, model, columns, state)
 395
 396 (* Callback function to open a connection.
 397  * This should be a lot more sophisticated. XXX
 398  *)
 399 let open_connection () =
 400   let title = "Open connection to hypervisor" in
 401   let uri =
 402     GToolbox.input_string ~title ~text:"xen:///" ~ok:"Open" "Connection:" in
 403   match uri with
 404   | None -> ()
 405   | Some uri ->
 406       (* If this fails, let the exception escape and be printed
 407        * in the global exception handler.
 408        *)
 409       let conn = C.connect ~name:uri () in
 410
 411       let node_info = C.get_node_info conn in
 412       let hostname =
 413         try Some (C.get_hostname conn)
 414         with
 415         | Libvirt.Not_supported "virConnectGetHostname"
 416         | Libvirt.Virterror _ -> None in
 417
 418       (* Add it to our list of connections. *)
 419       let conn_id = add_conn conn in
 420       Hashtbl.add static_conn_info conn_id (node_info, hostname, uri)