1 (* virt-ctrl: A graphical management tool.
2 (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
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.
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.
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.
21 open Virt_ctrl_gettext.Gettext
23 module C = Libvirt.Connect
24 module D = Libvirt.Domain
25 module N = Libvirt.Network
29 (* List of currently open connections. Actually it's a list of
30 * (id, Libvirt.Connect.t) so that we can easily identify
31 * connections by their unique ID.
33 let get_conns, add_conn, del_conn =
36 let get_conns () = !conns in
38 incr id; let id = !id in
39 conns := (id, conn) :: !conns;
43 conns := List.filter (fun (id', _) -> id <> id') !conns
45 get_conns, add_conn, del_conn
47 (* Store the node_info and hostname for each connection, fetched
48 * once just after we connect since these don't normally change.
49 * Hash of connid -> (C.node_info, hostname option, uri, capabilities)
51 let static_conn_info = Hashtbl.create 13
53 let open_connection uri =
54 (* If this fails, let the exception escape and be printed
55 * in the global exception handler.
57 let conn = C.connect ~name:uri () in
59 (* Get the static info from the connection. *)
60 let node_info = C.get_node_info conn in
62 try Some (C.get_hostname conn)
64 | Libvirt.Not_supported "virConnectGetHostname" -> None
65 | Libvirt.Virterror err ->
66 prerr_endline (Libvirt.Virterror.to_string err);
70 let caps = C.get_capabilities conn in
71 let caps = Xml.parse_string caps in
74 | Libvirt.Not_supported "virConnectGetCapabilities" -> None
75 | Libvirt.Virterror err ->
76 prerr_endline (Libvirt.Virterror.to_string err);
79 prerr_endline (Xml.error err);
82 (* Add it to our list of connections. *)
83 let conn_id = add_conn conn in
84 Hashtbl.add static_conn_info conn_id (node_info, hostname, uri, capabilities)
86 let get_node_info conn_id =
87 let node_info, _, _, _ = Hashtbl.find static_conn_info conn_id in
90 let get_hostname conn_id =
91 let _, hostname, _, _ = Hashtbl.find static_conn_info conn_id in
95 let _, _, uri, _ = Hashtbl.find static_conn_info conn_id in
98 let get_capabilities conn_id =
99 let _, _, _, capabilities = Hashtbl.find static_conn_info conn_id in
102 (* Stores the state and history for each domain.
103 * Hash of (connid, domid) -> mutable domhistory structure.
104 * We never delete entries in this hash table, which may be a problem
105 * for very very long-lived instances of virt-ctrl.
108 (* for %CPU calculation: *)
109 mutable last_cpu_time : int64; (* last virDomainInfo->cpuTime *)
110 mutable last_time : float; (* exact time we measured the above *)
112 (* historical data for graphs etc: *)
113 mutable hist : dhentry array; (* historical data *)
114 mutable hist_posn : int; (* position within array *)
117 hist_cpu : int; (* historical %CPU entry *)
118 hist_mem : int64; (* historical memory entry (KB) *)
121 let domhistory = Hashtbl.create 13
123 let empty_dhentry = {
124 hist_cpu = 0; hist_mem = 0L;
126 let new_domhistory () = {
127 last_cpu_time = 0L; last_time = 0.;
128 hist = Array.make 0 empty_dhentry; hist_posn = 0;
131 (* These set limits on the amount of history we collect. *)
132 let hist_max = 86400 (* max history stored, seconds *)
133 let hist_rot = 3600 (* rotation of array when we hit max *)
135 (* The current state. This is used so that we can see changes that
136 * have happened and add or remove parts of the model. (Previously
137 * we used to recreate the whole model each time, but the problem
138 * with that is we "forget" things like the selection).
140 type state = connection list
141 and connection = int (* connection ID *) * (active list * inactive list)
142 and active = int (* domain's ID *)
143 and inactive = string (* domain's name *)
145 (* The types of the display columns in the main window. The interesting
146 * one of the final (int) field which stores the ID of the row, either
149 type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column
151 let debug_repopulate = false
153 (* Populate the tree with the current list of connections, domains.
154 * This function is called once per second.
156 let repopulate (tree : GTree.view) (model : GTree.tree_store)
157 (col_name_id, col_domname, col_status, col_cpu, col_mem, col_id)
159 (* Which connections have been added or removed? *)
160 let conns = get_conns () in
161 let added, _, removed =
162 let old_conn_ids = List.map fst state
163 and new_conn_ids = List.map fst conns in
164 differences old_conn_ids new_conn_ids in
166 (* Remove the subtrees for any connections which have gone. *)
167 if debug_repopulate then List.iter (eprintf "-connection %d\n%!") removed;
171 filter_top_level_rows model
172 (fun row -> conn_id <> model#get ~row ~column:col_id)
175 (* Add placeholder subtree for any new connections. *)
176 if debug_repopulate then List.iter (eprintf "+connection %d\n%!") added;
180 let row = model#append () in
181 (* Get the connection name, usually the hostname. *)
183 match get_hostname conn_id with
184 | Some hostname -> hostname
185 | None -> sprintf "Conn #%d" conn_id in
186 model#set ~row ~column:col_name_id name;
187 model#set ~row ~column:col_id conn_id;
188 (* Expand the new row. *)
189 (* XXX This doesn't work, why? - Because we haven't created subrows yet.*)
190 tree#expand_row (model#get_path row)
195 fun (conn_id, conn) ->
196 (* Get the old list of active and inactive domains. If this
197 * connection is newly created, start with empty lists.
199 let old_active, old_inactive =
200 try List.assoc conn_id state
201 with Not_found -> [], [] in
203 (* Get the top level row in the model corresponding to this
207 try find_top_level_row model
208 (fun row -> conn_id = model#get ~row ~column:col_id)
209 with Not_found -> assert false (* Should never happen. *) in
212 (* Number of CPUs available. *)
213 let node_info = get_node_info conn_id in
214 let nr_cpus = C.maxcpus_of_node_info node_info in
216 (* For this connection, get a current list of active domains (IDs) *)
218 let n = C.num_of_domains conn in
219 let doms = C.list_domains conn n in
220 Array.to_list doms in
222 (* Which active domains have been added or removed? *)
223 let added, _, removed = differences old_active active in
225 (* Remove any active domains which have disappeared. *)
226 if debug_repopulate then
227 List.iter (eprintf "-active %d\n%!") removed;
232 (fun row -> domid <> model#get ~row ~column:col_id)
233 (model#iter_children (Some parent))
236 (* Add any active domains which have appeared. *)
237 if debug_repopulate then
238 List.iter (eprintf "+active %d\n%!") added;
244 let dom = D.lookup_by_id conn domid in
246 with _ -> "" in (* Ignore any transient error. *)
248 let row = model#append ~parent () in
249 model#set ~row ~column:col_name_id (string_of_int domid);
250 model#set ~row ~column:col_domname domname;
251 model#set ~row ~column:col_id domid
254 (* Get a current list of inactive domains (names). *)
256 let n = C.num_of_defined_domains conn in
257 let doms = C.list_defined_domains conn n in
258 Array.to_list doms in
260 (* Which inactive domains have been added or removed? *)
261 let added, _, removed = differences old_inactive inactive in
263 (* Remove any inactive domains which have disappeared. *)
264 if debug_repopulate then
265 List.iter (eprintf "-inactive %s\n%!") removed;
271 model#get ~row ~column:col_id <> -1 ||
272 model#get ~row ~column:col_domname <> domname)
273 (model#iter_children (Some parent))
276 (* Add any inactive domains which have appeared. *)
277 if debug_repopulate then
278 List.iter (eprintf "+inactive %s\n%!") added;
282 let row = model#append ~parent () in
283 model#set ~row ~column:col_name_id "";
284 model#set ~row ~column:col_domname domname;
285 model#set ~row ~column:col_status "inactive";
286 model#set ~row ~column:col_id (-1)
289 (* Now iterate over all active domains and update their state,
294 let domid = model#get ~row ~column:col_id in
295 if domid >= 0 then ( (* active *)
297 let dom = D.lookup_by_id conn domid in
298 let info = D.get_info dom in
299 let status = string_of_domain_state info.D.state in
300 model#set ~row ~column:col_status status;
301 let memory = sprintf "%Ld K" info.D.memory in
302 model#set ~row ~column:col_mem memory;
304 (* Get domhistory. For a new domain it won't exist, so
305 * create an empty one.
308 let key = conn_id, domid in
309 try Hashtbl.find domhistory key
311 let dh = new_domhistory () in
312 Hashtbl.add domhistory key dh;
315 (* Measure current time and domain cpuTime as close
316 * together as possible.
318 let time_now = Unix.gettimeofday () in
319 let cpu_now = info.D.cpu_time in
321 let time_prev = dh.last_time in
323 if dh.last_cpu_time > cpu_now then 0L (* Rebooted? *)
324 else dh.last_cpu_time in
326 dh.last_time <- time_now;
327 dh.last_cpu_time <- cpu_now;
330 if time_prev > 0. then (
331 let cpu_now = Int64.to_float cpu_now in
332 let cpu_prev = Int64.to_float cpu_prev in
333 let cpu_used = cpu_now -. cpu_prev in
334 let cpu_available = 1_000_000_000. *. float nr_cpus in
335 let time_passed = time_now -. time_prev in
338 100. *. (cpu_used /. cpu_available) /. time_passed in
341 if cpu_percent < 0. then 0.
342 else if cpu_percent > 100. then 100.
345 let cpu_percent_str = sprintf "%.1f %%" cpu_percent in
346 model#set ~row ~column:col_cpu cpu_percent_str;
347 int_of_float cpu_percent
351 let datum = { hist_cpu = cpu_percent;
352 hist_mem = info.D.memory } in
354 if dh.hist_posn >= hist_max then (
355 (* rotate the array *)
356 Array.blit dh.hist hist_rot dh.hist 0 (hist_max-hist_rot);
357 dh.hist_posn <- dh.hist_posn - hist_rot;
358 dh.hist.(dh.hist_posn) <- datum;
360 let len = Array.length dh.hist in
361 if dh.hist_posn < len then
363 dh.hist.(dh.hist_posn) <- datum
365 (* extend the array *)
366 let len' = min (max (2*len) 1) hist_max in
367 let arr' = Array.make len' datum in
368 Array.blit dh.hist 0 arr' 0 len;
372 dh.hist_posn <- dh.hist_posn+1
375 (* Ignore any transient error *)
376 | Libvirt.Virterror err ->
377 prerr_endline (Libvirt.Virterror.to_string err)
378 | Failure msg | Invalid_argument msg ->
381 ) (model#iter_children (Some parent));
383 (* Return new state. *)
384 conn_id, (active, inactive)
386 (* Libvirt errors here are not really fatal. They can happen
387 * if the state changes at the moment we read it. If it does
388 * happen, just return the old state, and next time we come
389 * around to this connection it'll be fixed.
391 | Libvirt.Virterror err ->
392 prerr_endline (Libvirt.Virterror.to_string err);
393 conn_id, (old_active, old_inactive)
394 | Failure msg | Invalid_argument msg ->
396 conn_id, (old_active, old_inactive)
399 (* Return the updated state. *)
402 (* Make the treeview which displays the connections and domains. *)
403 let make_treeview ?packing () =
404 let cols = new GTree.column_list in
405 let col_name_id = cols#add Gobject.Data.string in
406 let col_domname = cols#add Gobject.Data.string in
407 let col_status = cols#add Gobject.Data.string in
408 let col_cpu = cols#add Gobject.Data.string in
409 let col_mem = cols#add Gobject.Data.string in
410 (* Hidden column containing the connection ID or domain ID. For
411 * inactive domains, this contains -1 and col_domname is the name. *)
412 let col_id = cols#add Gobject.Data.int in
413 let model = GTree.tree_store cols in
415 (* Column sorting functions. *)
416 let make_sort_func_on column =
417 fun (model : GTree.model) row1 row2 ->
418 let col1 = model#get ~row:row1 ~column in
419 let col2 = model#get ~row:row2 ~column in
422 (*model#set_default_sort_func (make_sort_func_on col_domname);*)
423 model#set_sort_func 0 (make_sort_func_on col_name_id);
424 model#set_sort_func 1 (make_sort_func_on col_domname);
425 model#set_sort_column_id 1 `ASCENDING;
427 (* Make the GtkTreeView and attach column renderers to it. *)
428 let tree = GTree.view ~model ~reorderable:false ?packing () in
430 let append_visible_column title column sort =
431 let renderer = GTree.cell_renderer_text [], ["text", column] in
432 let view_col = GTree.view_column ~title ~renderer () in
433 ignore (tree#append_column view_col);
436 | Some (sort_indicator, sort_order, sort_column_id) ->
437 view_col#set_sort_indicator sort_indicator;
438 view_col#set_sort_order sort_order;
439 view_col#set_sort_column_id sort_column_id
441 append_visible_column (s_ "ID") col_name_id (Some (false, `ASCENDING, 0));
442 append_visible_column (s_ "Name") col_domname (Some (true, `ASCENDING, 1));
443 append_visible_column (s_ "Status") col_status None;
444 append_visible_column (s_ "CPU") col_cpu None;
445 append_visible_column (s_ "Memory") col_mem None;
448 col_name_id, col_domname, col_status, col_cpu, col_mem, col_id in
449 let state = repopulate tree model columns [] in
451 (tree, model, columns, state)
453 (* Get historical data size. *)
454 let get_hist_size connid domid =
456 let dh = Hashtbl.find domhistory (connid, domid) in
461 (* Get historical data entries. *)
462 let _get_hist ?(latest=0) ?earliest ?(granularity=1)
463 extract fold zero connid domid =
465 let dh = Hashtbl.find domhistory (connid, domid) in
468 | None -> dh.hist_posn
469 | Some e -> min e dh.hist_posn in
472 let src_start = dh.hist_posn - earliest in assert (src_start >= 0);
473 let src_end = dh.hist_posn - latest in assert (src_end <= dh.hist_posn);
475 (* Create a sufficiently large array to store the result. *)
476 let len = (earliest-latest) / granularity in
477 let r = Array.make len zero in
479 if granularity = 1 then (
480 for j = 0 to len-1 do
481 r.(j) <- extract src.(src_start+j)
484 let i = ref src_start in
485 for j = 0 to len-1 do
486 let sub = Array.sub src !i (min (!i+granularity) src_end - !i) in
487 let sub = Array.map extract sub in
489 i := !i + granularity
496 let get_hist_cpu ?latest ?earliest ?granularity connid domid =
498 let extract { hist_cpu = c } = c in
500 let len = Array.length a in
501 if len > 0 then Array.fold_left (+) zero a / len else -1 in
502 _get_hist ?latest ?earliest ?granularity extract fold zero connid domid
504 let get_hist_mem ?latest ?earliest ?granularity connid domid =
506 let extract { hist_mem = m } = m in
508 let len = Array.length a in
510 Int64.div (Array.fold_left (Int64.add) zero a) (Int64.of_int len)
513 _get_hist ?latest ?earliest ?granularity extract fold zero connid domid