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.
22 module C = Libvirt.Connect
23 module D = Libvirt.Domain
24 module N = Libvirt.Network
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.
32 let get_conns, add_conn, del_conn =
35 let get_conns () = !conns in
37 incr id; let id = !id in
38 conns := (id, conn) :: !conns;
42 conns := List.filter (fun (id', _) -> id <> id') !conns
44 get_conns, add_conn, del_conn
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).
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 *)
56 (* The last "CPU time" seen for a domain, so we can calculate CPU % usage.
57 * Hash of (connid, domid) -> cpu_time [int64].
59 let last_cpu_time = Hashtbl.create 13
60 let last_time = ref (Unix.gettimeofday ())
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)
66 let static_conn_info = Hashtbl.create 13
68 type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column
70 let debug_repopulate = true
72 (* Populate the tree with the current list of connections, domains.
73 * This function is called once per second.
75 let repopulate (tree : GTree.view) (model : GTree.tree_store)
76 (col_name_id, col_domname, col_status, col_cpu, col_mem, col_id)
79 let time_now = Unix.gettimeofday () in
80 let time_passed = time_now -. !last_time in
81 last_time := time_now;
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
91 (* Remove the subtrees for any connections which have gone. *)
92 if debug_repopulate then List.iter (eprintf "-connection %d\n%!") removed;
96 filter_top_level_rows model
97 (fun row -> conn_id <> model#get ~row ~column:col_id)
100 (* Add placeholder subtree for any new connections. *)
101 if debug_repopulate then List.iter (eprintf "+connection %d\n%!") added;
105 let row = model#append () in
106 (* Get the connection name, usually the hostname. *)
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)
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.
124 let old_active, old_inactive =
125 try List.assoc conn_id state
126 with Not_found -> [], [] in
128 (* Get the top level row in the model corresponding to this
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
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
141 (* For this connection, get a current list of active domains (IDs) *)
143 let n = C.num_of_domains conn in
144 let doms = C.list_domains conn n in
145 Array.to_list doms in
147 (* Which active domains have been added or removed? *)
148 let added, _, removed = differences old_active active in
150 (* Remove any active domains which have disappeared. *)
151 if debug_repopulate then
152 List.iter (eprintf "-active %d\n%!") removed;
157 (fun row -> domid <> model#get ~row ~column:col_id)
158 (model#iter_children (Some parent))
161 (* Add any active domains which have appeared. *)
162 if debug_repopulate then
163 List.iter (eprintf "+active %d\n%!") added;
169 let dom = D.lookup_by_id conn domid in
171 with _ -> "" in (* Ignore any transient error. *)
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
179 (* Get a current list of inactive domains (names). *)
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
185 (* Which inactive domains have been added or removed? *)
186 let added, _, removed = differences old_inactive inactive in
188 (* Remove any inactive domains which have disappeared. *)
189 if debug_repopulate then
190 List.iter (eprintf "-inactive %s\n%!") removed;
196 model#get ~row ~column:col_id <> -1 ||
197 model#get ~row ~column:col_domname <> domname)
198 (model#iter_children (Some parent))
201 (* Add any inactive domains which have appeared. *)
202 if debug_repopulate then
203 List.iter (eprintf "+inactive %s\n%!") added;
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)
214 (* Now iterate over all active domains and update their state,
219 let domid = model#get ~row ~column:col_id in
220 if domid >= 0 then ( (* active *)
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;
229 let ns_now = info.D.cpu_time in (* ns = nanoseconds *)
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
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;
245 with Libvirt.Virterror _ -> () (* Ignore any transient error *)
247 ) (model#iter_children (Some parent));
249 (* Return new state. *)
250 conn_id, (active, inactive)
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.
257 | Libvirt.Virterror err ->
258 prerr_endline (Libvirt.Virterror.to_string err);
259 conn_id, (old_active, old_inactive)
262 conn_id, (old_active, old_inactive)
265 (* Return the updated state. *)
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
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
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;
293 (* Make the GtkTreeView and attach column renderers to it. *)
294 let tree = GTree.view ~model ~reorderable:false ?packing () in
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);
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
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;
314 col_name_id, col_domname, col_status, col_cpu, col_mem, col_id in
315 let state = repopulate tree model columns [] in
317 (tree, model, columns, state)
319 (* Callback function to open a connection.
320 * This should be a lot more sophisticated. XXX
322 let open_connection () =
323 let title = "Open connection to hypervisor" in
325 GToolbox.input_string ~title ~text:"xen:///" ~ok:"Open" "Connection:" in
329 (* If this fails, let the exception escape and be printed
330 * in the global exception handler.
332 let conn = C.connect ~name:uri () in
334 let node_info = C.get_node_info conn in
336 try Some (C.get_hostname conn)
338 | Libvirt.Not_supported "virConnectGetHostname"
339 | Libvirt.Virterror _ -> None in
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)