1 (* virt-manager-like graphical management tool.
2 (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
4 $Id: mlvirtmanager_connections.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $
9 module C = Libvirt.Connect
10 module D = Libvirt.Domain
11 module N = Libvirt.Network
13 open Mlvirtmanager_helpers
15 (* List of currently open connections. Actually it's a list of
16 * (id, Libvirt.Connect.t) so that we can easily identify
17 * connections by their unique ID.
19 let get_conns, add_conn, del_conn =
22 let get_conns () = !conns in
24 incr id; let id = !id in
25 conns := (id, conn) :: !conns;
29 conns := List.filter (fun (id', _) -> id <> id') !conns
31 get_conns, add_conn, del_conn
33 (* The current state. This is used so that we can see changes that
34 * have happened and add or remove parts of the model. (Previously
35 * we used to recreate the whole model each time, but the problem
36 * with that is we "forget" things like the selection).
38 type state = connection list
39 and connection = int (* connection ID *) * (active list * inactive list)
40 and active = int (* domain's ID *)
41 and inactive = string (* domain's name *)
43 (* The last "CPU time" seen for a domain, so we can calculate CPU % usage.
44 * Hash of (connid, domid) -> cpu_time [int64].
46 let last_cpu_time = Hashtbl.create 13
47 let last_time = ref (Unix.gettimeofday ())
49 type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column
51 let debug_repopulate = true
53 (* Populate the tree with the current list of connections, domains.
54 * This function is called once per second.
56 let repopulate (tree : GTree.view) (model : GTree.tree_store)
57 (col_name_id, col_domname, col_status, col_cpu, col_mem, col_id)
60 let time_now = Unix.gettimeofday () in
61 let time_passed = time_now -. !last_time in
62 last_time := time_now;
65 (* Which connections have been added or removed? *)
66 let conns = get_conns () in
67 let added, _, removed =
68 let old_conn_ids = List.map fst state
69 and new_conn_ids = List.map fst conns in
70 differences old_conn_ids new_conn_ids in
72 (* Remove the subtrees for any connections which have gone. *)
73 if debug_repopulate then List.iter (eprintf "-connection %d\n%!") removed;
77 filter_top_level_rows model
78 (fun row -> conn_id <> model#get ~row ~column:col_id)
81 (* Add placeholder subtree for any new connections. *)
82 if debug_repopulate then List.iter (eprintf "+connection %d\n%!") added;
86 let row = model#append () in
87 (* Get the connection name. *)
89 try C.get_hostname (List.assoc conn_id conns)
90 with Not_found | Libvirt.Virterror _ ->
91 "Conn #" ^ string_of_int conn_id in
92 model#set ~row ~column:col_name_id name;
93 model#set ~row ~column:col_id conn_id;
94 (* XXX This doesn't work, why? *)
95 tree#expand_row (model#get_path row)
100 fun (conn_id, conn) ->
101 (* Get the old list of active and inactive domains. If this
102 * connection is newly created, start with empty lists.
104 let old_active, old_inactive =
105 try List.assoc conn_id state
106 with Not_found -> [], [] in
108 (* Get the top level row in the model corresponding to this
112 try find_top_level_row model
113 (fun row -> conn_id = model#get ~row ~column:col_id)
114 with Not_found -> assert false (* Should never happen. *) in
117 (* Node info & number of CPUs available. *)
118 let node_info = C.get_node_info conn in
119 let nr_cpus = C.maxcpus_of_node_info node_info in
121 (* For this connection, get a current list of active domains (IDs) *)
123 let n = C.num_of_domains conn in
124 let doms = C.list_domains conn n in
125 Array.to_list doms in
127 (* Which active domains have been added or removed? *)
128 let added, _, removed = differences old_active active in
130 (* Remove any active domains which have disappeared. *)
131 if debug_repopulate then
132 List.iter (eprintf "-active %d\n%!") removed;
137 (fun row -> domid <> model#get ~row ~column:col_id)
138 (model#iter_children (Some parent))
141 (* Add any active domains which have appeared. *)
142 if debug_repopulate then
143 List.iter (eprintf "+active %d\n%!") added;
149 let dom = D.lookup_by_id conn domid in
151 with _ -> "" in (* Ignore any transient error. *)
153 let row = model#append ~parent () in
154 model#set ~row ~column:col_name_id (string_of_int domid);
155 model#set ~row ~column:col_domname domname;
156 model#set ~row ~column:col_id domid
159 (* Get a current list of inactive domains (names). *)
161 let n = C.num_of_defined_domains conn in
162 let doms = C.list_defined_domains conn n in
163 Array.to_list doms in
165 (* Which inactive domains have been added or removed? *)
166 let added, _, removed = differences old_inactive inactive in
168 (* Remove any inactive domains which have disappeared. *)
169 if debug_repopulate then
170 List.iter (eprintf "-inactive %s\n%!") removed;
176 model#get ~row ~column:col_id <> -1 ||
177 model#get ~row ~column:col_domname <> domname)
178 (model#iter_children (Some parent))
181 (* Add any inactive domains which have appeared. *)
182 if debug_repopulate then
183 List.iter (eprintf "+inactive %s\n%!") added;
187 let row = model#append ~parent () in
188 model#set ~row ~column:col_name_id "";
189 model#set ~row ~column:col_domname domname;
190 model#set ~row ~column:col_status "inactive";
191 model#set ~row ~column:col_id (-1)
194 (* Now iterate over all active domains and update their state,
199 let domid = model#get ~row ~column:col_id in
200 if domid >= 0 then ( (* active *)
202 let dom = D.lookup_by_id conn domid in
203 let info = D.get_info dom in
204 let status = string_of_domain_state info.D.state in
205 model#set ~row ~column:col_status status;
206 let memory = sprintf "%Ld K" info.D.memory in
207 model#set ~row ~column:col_mem memory;
209 let ns_now = info.D.cpu_time in (* ns = nanoseconds *)
212 let ns = Hashtbl.find last_cpu_time (conn_id, domid) in
213 if ns > ns_now then 0L else ns (* Rebooted? *)
214 with Not_found -> 0L in
215 Hashtbl.replace last_cpu_time (conn_id, domid) ns_now;
216 let ns_now = Int64.to_float ns_now in
217 let ns_prev = Int64.to_float ns_prev in
218 let ns_used = ns_now -. ns_prev in
219 let ns_available = 1_000_000_000. *. float nr_cpus in
221 100. *. (ns_used /. ns_available) /. time_passed in
222 let cpu_percent = sprintf "%.1f %%" cpu_percent in
223 model#set ~row ~column:col_cpu cpu_percent;
225 with Libvirt.Virterror _ -> () (* Ignore any transient error *)
227 ) (model#iter_children (Some parent));
229 (* Return new state. *)
230 conn_id, (active, inactive)
232 (* Libvirt errors here are not really fatal. They can happen
233 * if the state changes at the moment we read it. If it does
234 * happen, just return the old state, and next time we come
235 * around to this connection it'll be fixed.
237 | Libvirt.Virterror err ->
238 prerr_endline (Libvirt.Virterror.to_string err);
239 conn_id, (old_active, old_inactive)
242 conn_id, (old_active, old_inactive)
245 (* Return the updated state. *)
248 (* Make the treeview which displays the connections and domains. *)
249 let make_treeview ?packing () =
250 let cols = new GTree.column_list in
251 let col_name_id = cols#add Gobject.Data.string in
252 let col_domname = cols#add Gobject.Data.string in
253 let col_status = cols#add Gobject.Data.string in
254 let col_cpu = cols#add Gobject.Data.string in
255 let col_mem = cols#add Gobject.Data.string in
256 (* Hidden column containing the connection ID or domain ID. For
257 * inactive domains, this contains -1 and col_domname is the name. *)
258 let col_id = cols#add Gobject.Data.int in
259 let model = GTree.tree_store cols in
261 (* Column sorting functions. *)
262 let make_sort_func_on column =
263 fun (model : GTree.model) row1 row2 ->
264 let col1 = model#get ~row:row1 ~column in
265 let col2 = model#get ~row:row2 ~column in
268 (*model#set_default_sort_func (make_sort_func_on col_domname);*)
269 model#set_sort_func 0 (make_sort_func_on col_name_id);
270 model#set_sort_func 1 (make_sort_func_on col_domname);
271 model#set_sort_column_id 1 `ASCENDING;
273 (* Make the GtkTreeView and attach column renderers to it. *)
274 let tree = GTree.view ~model ~reorderable:false ?packing () in
276 let append_visible_column title column sort =
277 let renderer = GTree.cell_renderer_text [], ["text", column] in
278 let view_col = GTree.view_column ~title ~renderer () in
279 ignore (tree#append_column view_col);
282 | Some (sort_indicator, sort_order, sort_column_id) ->
283 view_col#set_sort_indicator sort_indicator;
284 view_col#set_sort_order sort_order;
285 view_col#set_sort_column_id sort_column_id
287 append_visible_column "ID" col_name_id (Some (false, `ASCENDING, 0));
288 append_visible_column "Name" col_domname (Some (true, `ASCENDING, 1));
289 append_visible_column "Status" col_status None;
290 append_visible_column "CPU" col_cpu None;
291 append_visible_column "Memory" col_mem None;
294 col_name_id, col_domname, col_status, col_cpu, col_mem, col_id in
295 let state = repopulate tree model columns [] in
297 (tree, model, columns, state)
299 (* Callback function to open a connection.
300 * This should be a lot more sophisticated. XXX
302 let open_connection () =
303 let title = "Open connection to hypervisor" in
305 GToolbox.input_string ~title ~text:"xen:///" ~ok:"Open" "Connection:" in
309 (* If this fails, let the exception escape and be printed
310 * in the global exception handler.
312 let conn = C.connect ~name () in
313 ignore (add_conn conn)