diff options
Diffstat (limited to 'virt-ctrl/vc_connections.ml')
| -rw-r--r-- | virt-ctrl/vc_connections.ml | 476 |
1 files changed, 0 insertions, 476 deletions
diff --git a/virt-ctrl/vc_connections.ml b/virt-ctrl/vc_connections.ml deleted file mode 100644 index 05024c5..0000000 --- a/virt-ctrl/vc_connections.ml +++ /dev/null @@ -1,476 +0,0 @@ -(* 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 |