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