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