(* virt-ctrl: A graphical management tool. (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. http://libvirt.org/ This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) open Printf module C = Libvirt.Connect module D = Libvirt.Domain module N = Libvirt.Network open Vc_helpers (* List of currently open connections. Actually it's a list of * (id, Libvirt.Connect.t) so that we can easily identify * connections by their unique ID. *) let get_conns, add_conn, del_conn = let conns = ref [] in let id = ref 0 in let get_conns () = !conns in let add_conn conn = incr id; let id = !id in conns := (id, conn) :: !conns; id in let del_conn id = conns := List.filter (fun (id', _) -> id <> id') !conns in get_conns, add_conn, del_conn (* Store the node_info and hostname for each connection, fetched * once just after we connect since these don't normally change. * Hash of connid -> (C.node_info, hostname option, uri) *) let static_conn_info = Hashtbl.create 13 let open_connection uri = (* If this fails, let the exception escape and be printed * in the global exception handler. *) let conn = C.connect ~name:uri () in let node_info = C.get_node_info conn in let hostname = try Some (C.get_hostname conn) with | Libvirt.Not_supported "virConnectGetHostname" | Libvirt.Virterror _ -> None in (* Add it to our list of connections. *) let conn_id = add_conn conn in Hashtbl.add static_conn_info conn_id (node_info, hostname, uri) (* Stores the state and history for each domain. * Hash of (connid, domid) -> mutable domhistory structure. * We never delete entries in this hash table, which may be a problem * for very very long-lived instances of virt-ctrl. *) type domhistory = { (* for %CPU calculation: *) mutable last_cpu_time : int64; (* last virDomainInfo->cpuTime *) mutable last_time : float; (* exact time we measured the above *) (* historical data for graphs etc: *) mutable hist : dhentry array; (* historical data *) mutable hist_posn : int; (* position within array *) } and dhentry = { hist_cpu : int; (* historical %CPU entry *) hist_mem : int64; (* historical memory entry (KB) *) } let domhistory = Hashtbl.create 13 let empty_dhentry = { hist_cpu = 0; hist_mem = 0L; } let new_domhistory () = { last_cpu_time = 0L; last_time = 0.; hist = Array.make 0 empty_dhentry; hist_posn = 0; } (* These set limits on the amount of history we collect. *) let hist_max = 86400 (* max history stored, seconds *) let hist_rot = 3600 (* rotation of array when we hit max *) (* The current state. This is used so that we can see changes that * have happened and add or remove parts of the model. (Previously * we used to recreate the whole model each time, but the problem * with that is we "forget" things like the selection). *) type state = connection list and connection = int (* connection ID *) * (active list * inactive list) and active = int (* domain's ID *) and inactive = string (* domain's name *) (* The types of the display columns in the main window. The interesting * one of the final (int) field which stores the ID of the row, either * connid or domid. *) type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column let debug_repopulate = false (* Populate the tree with the current list of connections, domains. * This function is called once per second. *) let repopulate (tree : GTree.view) (model : GTree.tree_store) (col_name_id, col_domname, col_status, col_cpu, col_mem, col_id) state = (* Which connections have been added or removed? *) let conns = get_conns () in let added, _, removed = let old_conn_ids = List.map fst state and new_conn_ids = List.map fst conns in differences old_conn_ids new_conn_ids in (* Remove the subtrees for any connections which have gone. *) if debug_repopulate then List.iter (eprintf "-connection %d\n%!") removed; List.iter ( fun conn_id -> filter_top_level_rows model (fun row -> conn_id <> model#get ~row ~column:col_id) ) removed; (* Add placeholder subtree for any new connections. *) if debug_repopulate then List.iter (eprintf "+connection %d\n%!") added; List.iter ( fun conn_id -> let row = model#append () in (* Get the connection name, usually the hostname. *) let name = match Hashtbl.find static_conn_info conn_id with | (_, Some hostname, _) -> hostname | (_, None, _) -> sprintf "Conn #%d" conn_id in model#set ~row ~column:col_name_id name; model#set ~row ~column:col_id conn_id; (* Expand the new row. *) (* XXX This doesn't work, why? - Because we haven't create subrows yet.*) tree#expand_row (model#get_path row) ) added; let new_state = List.map ( fun (conn_id, conn) -> (* Get the old list of active and inactive domains. If this * connection is newly created, start with empty lists. *) let old_active, old_inactive = try List.assoc conn_id state with Not_found -> [], [] in (* Get the top level row in the model corresponding to this * connection. *) let parent = try find_top_level_row model (fun row -> conn_id = model#get ~row ~column:col_id) with Not_found -> assert false (* Should never happen. *) in try (* Number of CPUs available. *) let node_info, _, _ = Hashtbl.find static_conn_info conn_id in let nr_cpus = C.maxcpus_of_node_info node_info in (* For this connection, get a current list of active domains (IDs) *) let active = let n = C.num_of_domains conn in let doms = C.list_domains conn n in Array.to_list doms in (* Which active domains have been added or removed? *) let added, _, removed = differences old_active active in (* Remove any active domains which have disappeared. *) if debug_repopulate then List.iter (eprintf "-active %d\n%!") removed; List.iter ( fun domid -> filter_rows model (fun row -> domid <> model#get ~row ~column:col_id) (model#iter_children (Some parent)) ) removed; (* Add any active domains which have appeared. *) if debug_repopulate then List.iter (eprintf "+active %d\n%!") added; List.iter ( fun domid -> let domname = try let dom = D.lookup_by_id conn domid in D.get_name dom with _ -> "" in (* Ignore any transient error. *) let row = model#append ~parent () in model#set ~row ~column:col_name_id (string_of_int domid); model#set ~row ~column:col_domname domname; model#set ~row ~column:col_id domid ) added; (* Get a current list of inactive domains (names). *) let inactive = let n = C.num_of_defined_domains conn in let doms = C.list_defined_domains conn n in Array.to_list doms in (* Which inactive domains have been added or removed? *) let added, _, removed = differences old_inactive inactive in (* Remove any inactive domains which have disappeared. *) if debug_repopulate then List.iter (eprintf "-inactive %s\n%!") removed; List.iter ( fun domname -> filter_rows model (fun row -> model#get ~row ~column:col_id <> -1 || model#get ~row ~column:col_domname <> domname) (model#iter_children (Some parent)) ) removed; (* Add any inactive domains which have appeared. *) if debug_repopulate then List.iter (eprintf "+inactive %s\n%!") added; List.iter ( fun domname -> let row = model#append ~parent () in model#set ~row ~column:col_name_id ""; model#set ~row ~column:col_domname domname; model#set ~row ~column:col_status "inactive"; model#set ~row ~column:col_id (-1) ) added; (* Now iterate over all active domains and update their state, * CPU and memory. *) iter_rows model ( fun row -> let domid = model#get ~row ~column:col_id in if domid >= 0 then ( (* active *) try let dom = D.lookup_by_id conn domid in let info = D.get_info dom in let status = string_of_domain_state info.D.state in model#set ~row ~column:col_status status; let memory = sprintf "%Ld K" info.D.memory in model#set ~row ~column:col_mem memory; (* Get domhistory. For a new domain it won't exist, so * create an empty one. *) let dh = let key = conn_id, domid in try Hashtbl.find domhistory key with Not_found -> let dh = new_domhistory () in Hashtbl.add domhistory key dh; dh in (* Measure current time and domain cpuTime as close * together as possible. *) let time_now = Unix.gettimeofday () in let cpu_now = info.D.cpu_time in let time_prev = dh.last_time in let cpu_prev = if dh.last_cpu_time > cpu_now then 0L (* Rebooted? *) else dh.last_cpu_time in dh.last_time <- time_now; dh.last_cpu_time <- cpu_now; let cpu_percent = if time_prev > 0. then ( let cpu_now = Int64.to_float cpu_now in let cpu_prev = Int64.to_float cpu_prev in let cpu_used = cpu_now -. cpu_prev in let cpu_available = 1_000_000_000. *. float nr_cpus in let time_passed = time_now -. time_prev in let cpu_percent = 100. *. (cpu_used /. cpu_available) /. time_passed in let cpu_percent = if cpu_percent < 0. then 0. else if cpu_percent > 100. then 100. else cpu_percent in let cpu_percent_str = sprintf "%.1f %%" cpu_percent in model#set ~row ~column:col_cpu cpu_percent_str; int_of_float cpu_percent ) else -1 in (* Store history. *) let datum = { hist_cpu = cpu_percent; hist_mem = info.D.memory } in if dh.hist_posn >= hist_max then ( (* rotate the array *) Array.blit dh.hist hist_rot dh.hist 0 (hist_max-hist_rot); dh.hist_posn <- dh.hist_posn - hist_rot; dh.hist.(dh.hist_posn) <- datum; ) else ( let len = Array.length dh.hist in if dh.hist_posn < len then (* normal update *) dh.hist.(dh.hist_posn) <- datum else ( (* extend the array *) let len' = min (max (2*len) 1) hist_max in let arr' = Array.make len' datum in Array.blit dh.hist 0 arr' 0 len; dh.hist <- arr'; ) ); dh.hist_posn <- dh.hist_posn+1 with Libvirt.Virterror _ -> () (* Ignore any transient error *) ) ) (model#iter_children (Some parent)); (* Return new state. *) conn_id, (active, inactive) with (* Libvirt errors here are not really fatal. They can happen * if the state changes at the moment we read it. If it does * happen, just return the old state, and next time we come * around to this connection it'll be fixed. *) | Libvirt.Virterror err -> prerr_endline (Libvirt.Virterror.to_string err); conn_id, (old_active, old_inactive) | Failure msg -> prerr_endline msg; conn_id, (old_active, old_inactive) ) conns in (* Return the updated state. *) new_state (* Make the treeview which displays the connections and domains. *) let make_treeview ?packing () = let cols = new GTree.column_list in let col_name_id = cols#add Gobject.Data.string in let col_domname = cols#add Gobject.Data.string in let col_status = cols#add Gobject.Data.string in let col_cpu = cols#add Gobject.Data.string in let col_mem = cols#add Gobject.Data.string in (* Hidden column containing the connection ID or domain ID. For * inactive domains, this contains -1 and col_domname is the name. *) let col_id = cols#add Gobject.Data.int in let model = GTree.tree_store cols in (* Column sorting functions. *) let make_sort_func_on column = fun (model : GTree.model) row1 row2 -> let col1 = model#get ~row:row1 ~column in let col2 = model#get ~row:row2 ~column in compare col1 col2 in (*model#set_default_sort_func (make_sort_func_on col_domname);*) model#set_sort_func 0 (make_sort_func_on col_name_id); model#set_sort_func 1 (make_sort_func_on col_domname); model#set_sort_column_id 1 `ASCENDING; (* Make the GtkTreeView and attach column renderers to it. *) let tree = GTree.view ~model ~reorderable:false ?packing () in let append_visible_column title column sort = let renderer = GTree.cell_renderer_text [], ["text", column] in let view_col = GTree.view_column ~title ~renderer () in ignore (tree#append_column view_col); match sort with | None -> () | Some (sort_indicator, sort_order, sort_column_id) -> view_col#set_sort_indicator sort_indicator; view_col#set_sort_order sort_order; view_col#set_sort_column_id sort_column_id in append_visible_column "ID" col_name_id (Some (false, `ASCENDING, 0)); append_visible_column "Name" col_domname (Some (true, `ASCENDING, 1)); append_visible_column "Status" col_status None; append_visible_column "CPU" col_cpu None; append_visible_column "Memory" col_mem None; let columns = col_name_id, col_domname, col_status, col_cpu, col_mem, col_id in let state = repopulate tree model columns [] in (tree, model, columns, state) (* Get historical data size. *) let get_hist_size connid domid = try let dh = Hashtbl.find domhistory (connid, domid) in dh.hist_posn with Not_found -> 0 (* Get historical data entries. *) let _get_hist ?(latest=0) ?earliest ?(granularity=1) extract fold zero connid domid = try let dh = Hashtbl.find domhistory (connid, domid) in let earliest = match earliest with | None -> dh.hist_posn | Some e -> min e dh.hist_posn in let src = dh.hist in let src_start = dh.hist_posn - earliest in assert (src_start >= 0); let src_end = dh.hist_posn - latest in assert (src_end <= dh.hist_posn); (* Create a sufficiently large array to store the result. *) let len = (earliest-latest) / granularity in let r = Array.make len zero in if granularity = 1 then ( for j = 0 to len-1 do r.(j) <- extract src.(src_start+j) done ) else ( let i = ref src_start in for j = 0 to len-1 do let sub = Array.sub src !i (min (!i+granularity) src_end - !i) in let sub = Array.map extract sub in r.(j) <- fold sub; i := !i + granularity done ); r with Not_found -> [| |] let get_hist_cpu ?latest ?earliest ?granularity connid domid = let zero = 0 in let extract { hist_cpu = c } = c in let fold a = let len = Array.length a in if len > 0 then Array.fold_left (+) zero a / len else -1 in _get_hist ?latest ?earliest ?granularity extract fold zero connid domid let get_hist_mem ?latest ?earliest ?granularity connid domid = let zero = 0L in let extract { hist_mem = m } = m in let fold a = let len = Array.length a in if len > 0 then Int64.div (Array.fold_left (Int64.add) zero a) (Int64.of_int len) else -1L in _get_hist ?latest ?earliest ?granularity extract fold zero connid domid