From 90d14bc151e488972d33eefaac2242d9a6e07578 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 27 Mar 2017 15:29:23 +0100 Subject: [PATCH 13/19] Split up huge Top module into smaller modules. This change is hopefully pure refactoring, splitting up the very large and highly interlinked module into more manageable modules with well-defined (or at least *better*-defined) interfaces between them. --- MANIFEST | 12 + po/POTFILES | 6 + src/.depend | 36 +- src/Makefile.in | 6 + src/README | 36 +- src/collect.ml | 455 ++++++++++++++++++++ src/collect.mli | 86 ++++ src/csv_output.ml | 118 +++++ src/csv_output.mli | 27 ++ src/opt_csv.ml | 2 +- src/opt_xml.ml | 2 +- src/redraw.ml | 506 ++++++++++++++++++++++ src/redraw.mli | 20 + src/screen.ml | 52 +++ src/screen.mli | 41 ++ src/stream_output.ml | 84 ++++ src/stream_output.mli | 22 + src/top.ml | 1139 ++----------------------------------------------- src/top.mli | 20 +- src/types.ml | 147 +++++++ src/types.mli | 49 +++ src/utils.ml | 65 --- src/utils.mli | 9 - 23 files changed, 1718 insertions(+), 1222 deletions(-) create mode 100644 src/collect.ml create mode 100644 src/collect.mli create mode 100644 src/csv_output.ml create mode 100644 src/csv_output.mli create mode 100644 src/redraw.ml create mode 100644 src/redraw.mli create mode 100644 src/screen.ml create mode 100644 src/screen.mli create mode 100644 src/stream_output.ml create mode 100644 src/stream_output.mli create mode 100644 src/types.ml create mode 100644 src/types.mli diff --git a/MANIFEST b/MANIFEST index 26e87b2..4e4014b 100644 --- a/MANIFEST +++ b/MANIFEST @@ -54,12 +54,24 @@ TODO src/.depend src/Makefile.in src/README +src/collect.ml +src/collect.mli +src/csv_output.ml +src/csv_output.mli src/main.ml src/opt_calendar.ml src/opt_csv.ml src/opt_xml.ml +src/redraw.ml +src/redraw.mli +src/screen.ml +src/screen.mli +src/stream_output.ml +src/stream_output.mli src/top.ml src/top.mli +src/types.ml +src/types.mli src/utils.ml src/utils.mli src/version.ml.in diff --git a/po/POTFILES b/po/POTFILES index b826a2a..6150703 100644 --- a/po/POTFILES +++ b/po/POTFILES @@ -1,8 +1,14 @@ +../src/collect.ml +../src/csv_output.ml ../src/main.ml ../src/opt_calendar.ml ../src/opt_csv.ml ../src/opt_gettext.ml ../src/opt_xml.ml +../src/redraw.ml +../src/screen.ml +../src/stream.ml ../src/top.ml +../src/types.ml ../src/utils.ml ../src/version.ml diff --git a/src/.depend b/src/.depend index f487c18..1075f36 100644 --- a/src/.depend +++ b/src/.depend @@ -1,18 +1,36 @@ +collect.cmi: types.cmi +collect.cmo: utils.cmi types.cmi collect.cmi +collect.cmx: utils.cmx types.cmx collect.cmi +csv_output.cmi: types.cmi collect.cmi +csv_output.cmo: collect.cmi csv_output.cmi +csv_output.cmx: collect.cmx csv_output.cmi main.cmo: top.cmi opt_gettext.cmo main.cmx: top.cmx opt_gettext.cmx opt_calendar.cmo: top.cmi opt_gettext.cmo opt_calendar.cmx: top.cmx opt_gettext.cmx -opt_csv.cmo: top.cmi opt_gettext.cmo -opt_csv.cmx: top.cmx opt_gettext.cmx +opt_csv.cmo: top.cmi opt_gettext.cmo csv_output.cmi +opt_csv.cmx: top.cmx opt_gettext.cmx csv_output.cmx opt_gettext.cmo: opt_gettext.cmx: -opt_xml.cmo: top.cmi opt_gettext.cmo -opt_xml.cmx: top.cmx opt_gettext.cmx -top.cmi: -top.cmo: version.cmo utils.cmi opt_gettext.cmo top.cmi -top.cmx: version.cmx utils.cmx opt_gettext.cmx top.cmi +opt_xml.cmo: opt_gettext.cmo collect.cmi +opt_xml.cmx: opt_gettext.cmx collect.cmx +redraw.cmi: types.cmi collect.cmi +redraw.cmo: utils.cmi types.cmi screen.cmi opt_gettext.cmo collect.cmi redraw.cmi +redraw.cmx: utils.cmx types.cmx screen.cmx opt_gettext.cmx collect.cmx redraw.cmi +screen.cmi: +screen.cmo: screen.cmi +screen.cmx: screen.cmi +stream_output.cmi: types.cmi collect.cmi +stream_output.cmo: utils.cmi screen.cmi collect.cmi stream_output.cmi +stream_output.cmx: utils.cmx screen.cmx collect.cmx stream_output.cmi +top.cmi: types.cmi +top.cmo: version.cmo utils.cmi types.cmi stream_output.cmi screen.cmi redraw.cmi opt_gettext.cmo csv_output.cmi collect.cmi top.cmi +top.cmx: version.cmx utils.cmx types.cmx stream_output.cmx screen.cmx redraw.cmx opt_gettext.cmx csv_output.cmx collect.cmx top.cmi +types.cmi: +types.cmo: utils.cmi opt_gettext.cmo types.cmi +types.cmx: utils.cmx opt_gettext.cmx types.cmi utils.cmi: -utils.cmo: opt_gettext.cmo utils.cmi -utils.cmx: opt_gettext.cmx utils.cmi +utils.cmo: utils.cmi +utils.cmx: utils.cmi version.cmo: version.cmx: diff --git a/src/Makefile.in b/src/Makefile.in index ae896cb..64f431e 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -42,6 +42,12 @@ OBJS := \ version.cmo \ opt_gettext.cmo \ utils.cmo \ + types.cmo \ + collect.cmo \ + screen.cmo \ + redraw.cmo \ + csv_output.cmo \ + stream_output.cmo \ top.cmo ifneq ($(OCAML_PKG_xml_light),no) OBJS += opt_xml.cmo diff --git a/src/README b/src/README index 8aa2348..1fd4be3 100644 --- a/src/README +++ b/src/README @@ -5,19 +5,37 @@ The code is structured into these files: String functions and other small utility functions. This is included directly into virt_top.ml. - top.mli, top.ml + types.mli, types.ml - This is the virt-top program. + Various internally used types and functions operating on those + types. + + collect.mli, collect.ml + + Stats information is collected in these functions. + + screen.mli, screen.ml + + Various useful functions for drawing to the curses screen. + + redraw.mli, redraw.ml - The two interesting functions are called 'collect' and 'redraw'. + Redraw the main display. - 'collect' collects all the information about domains, etc. + csv_output.mli, csv_output.ml - 'redraw' updates the display on each frame. + Functions which implement --csv mode. + + stream_output.mli, stream_output.ml + + Functions which implement --stream mode. + + top.mli, top.ml + + This is the virt-top program. - Another interesting function is 'start_up' which handles all - start-up stuff, eg. command line arguments, connecting to the - hypervisor, enabling curses. + 'start_up' handles all start-up stuff, eg. command line arguments, + connecting to the hypervisor, enabling curses. The function 'main_loop' runs the main loop and has sub-functions to deal with keypresses, help screens and so on. @@ -38,7 +56,7 @@ The code is structured into these files: opt_csv.ml Any code which needs the optional ocaml-csv library goes - in here. This implements the --csv command line option. + in here. opt_calendar.ml diff --git a/src/collect.ml b/src/collect.ml new file mode 100644 index 0000000..f856067 --- /dev/null +++ b/src/collect.ml @@ -0,0 +1,455 @@ +(* 'top'-like tool for libvirt domains. + (C) Copyright 2007-2017 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. +*) + +module C = Libvirt.Connect +module D = Libvirt.Domain + +open Printf +open ExtList + +open Utils +open Types + +(* Hook for XML support (see [opt_xml.ml]). *) +let parse_device_xml : (int -> [>`R] D.t -> string list * string list) ref = + ref ( + fun _ _ -> [], [] + ) + +(* Intermediate "domain + stats" structure that we use to collect + * everything we know about a domain within the collect function. + *) +type rd_domain = Inactive | Active of rd_active +and rd_active = { + rd_domid : int; (* Domain ID. *) + rd_dom : [`R] D.t; (* Domain object. *) + rd_info : D.info; (* Domain CPU info now. *) + rd_block_stats : (string * D.block_stats) list; + (* Domain block stats now. *) + rd_interface_stats : (string * D.interface_stats) list; + (* Domain net stats now. *) + rd_prev_info : D.info option; (* Domain CPU info previously. *) + rd_prev_block_stats : (string * D.block_stats) list; + (* Domain block stats prev. *) + rd_prev_interface_stats : (string * D.interface_stats) list; + (* Domain interface stats prev. *) + (* The following are since the last slice, or 0 if cannot be calculated: *) + rd_cpu_time : float; (* CPU time used in nanoseconds. *) + rd_percent_cpu : float; (* CPU time as percent of total. *) + rd_mem_bytes : int64; (* Memory usage in bytes *) + rd_mem_percent: int64; (* Memory usage as percent of total *) + (* The following are since the last slice, or None if cannot be calc'd: *) + rd_block_rd_reqs : int64 option; (* Number of block device read rqs. *) + rd_block_wr_reqs : int64 option; (* Number of block device write rqs. *) + rd_block_rd_bytes : int64 option; (* Number of bytes block device read *) + rd_block_wr_bytes : int64 option; (* Number of bytes block device write *) + (* _info fields includes the number considering --block_in_bytes option *) + rd_block_rd_info : int64 option; (* Block device read info for user *) + rd_block_wr_info : int64 option; (* Block device read info for user *) + + rd_net_rx_bytes : int64 option; (* Number of bytes received. *) + rd_net_tx_bytes : int64 option; (* Number of bytes transmitted. *) +} + +type stats = { + rd_doms : (string * rd_domain) list; (* List of domains. *) + rd_time : float; + rd_printable_time : string; + rd_nr_pcpus : int; + rd_total_cpu : float; + rd_total_cpu_per_pcpu : float; + rd_totals : (int * int * int * int * int * int * int * int * int * float * + int64 * int64); +} + +type pcpu_stats = { + rd_pcpu_doms : (int * string * int * + Libvirt.Domain.vcpu_info array * int64 array array * + int64 array array * string * int) list; + rd_pcpu_pcpus : int64 array array array; + rd_pcpu_pcpus_cpu_time : float array +} + +(* We cache the list of block devices and interfaces for each domain + * here, so we don't need to reparse the XML each time. + *) +let devices = Hashtbl.create 13 + +(* Function to get the list of block devices, network interfaces for + * a particular domain. Get it from the devices cache, and if not + * there then parse the domain XML. + *) +let get_devices id dom = + try Hashtbl.find devices id + with Not_found -> + let blkdevs, netifs = (!parse_device_xml) id dom in + Hashtbl.replace devices id (blkdevs, netifs); + blkdevs, netifs + +(* We save the state of domains across redraws here, which allows us + * to deduce %CPU usage from the running total. + *) +let last_info = Hashtbl.create 13 +let last_time = ref (Unix.gettimeofday ()) + +(* Save pcpu_usages structures across redraws too (only for pCPU display). *) +let last_pcpu_usages = Hashtbl.create 13 + +let clear_pcpu_display_data () = + Hashtbl.clear last_pcpu_usages + +let collect (conn, _, _, _, _, node_info, _, _) block_in_bytes = + (* Number of physical CPUs (some may be disabled). *) + let nr_pcpus = C.maxcpus_of_node_info node_info in + + (* Get the current time. *) + let time = Unix.gettimeofday () in + let tm = Unix.localtime time in + let printable_time = + sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in + + (* What's the total CPU time elapsed since we were last called? (ns) *) + let total_cpu_per_pcpu = 1_000_000_000. *. (time -. !last_time) in + (* Avoid division by zero. *) + let total_cpu_per_pcpu = + if total_cpu_per_pcpu <= 0. then 1. else total_cpu_per_pcpu in + let total_cpu = float node_info.C.cpus *. total_cpu_per_pcpu in + + (* Get the domains. Match up with their last_info (if any). *) + let doms = + (* Active domains. *) + let n = C.num_of_domains conn in + let ids = + if n > 0 then Array.to_list (C.list_domains conn n) + else [] in + let doms = + List.filter_map ( + fun id -> + try + let dom = D.lookup_by_id conn id in + let name = D.get_name dom in + let blkdevs, netifs = get_devices id dom in + + (* Get current CPU, block and network stats. *) + let info = D.get_info dom in + let block_stats = + try List.map (fun dev -> dev, D.block_stats dom dev) blkdevs + with + | Libvirt.Not_supported "virDomainBlockStats" + | Libvirt.Virterror _ -> [] in + let interface_stats = + try List.map (fun dev -> dev, D.interface_stats dom dev) netifs + with + | Libvirt.Not_supported "virDomainInterfaceStats" + | Libvirt.Virterror _ -> [] in + + let prev_info, prev_block_stats, prev_interface_stats = + try + let prev_info, prev_block_stats, prev_interface_stats = + Hashtbl.find last_info id in + Some prev_info, prev_block_stats, prev_interface_stats + with Not_found -> None, [], [] in + + Some (name, + Active { + rd_domid = id; rd_dom = dom; rd_info = info; + rd_block_stats = block_stats; + rd_interface_stats = interface_stats; + rd_prev_info = prev_info; + rd_prev_block_stats = prev_block_stats; + rd_prev_interface_stats = prev_interface_stats; + rd_cpu_time = 0.; rd_percent_cpu = 0.; + rd_mem_bytes = 0L; rd_mem_percent = 0L; + rd_block_rd_reqs = None; rd_block_wr_reqs = None; + rd_block_rd_bytes = None; rd_block_wr_bytes = None; + rd_block_rd_info = None; rd_block_wr_info = None; + rd_net_rx_bytes = None; rd_net_tx_bytes = None; + }) + with + Libvirt.Virterror _ -> None (* ignore transient error *) + ) ids in + + (* Inactive domains. *) + let doms_inactive = + try + let n = C.num_of_defined_domains conn in + let names = + if n > 0 then Array.to_list (C.list_defined_domains conn n) + else [] in + List.map (fun name -> name, Inactive) names + with + (* Ignore transient errors, in particular errors from + * num_of_defined_domains if it cannot contact xend. + *) + | Libvirt.Virterror _ -> [] in + + doms @ doms_inactive in + + (* Calculate the CPU time (ns) and %CPU used by each domain. *) + let doms = + List.map ( + function + (* We have previous CPU info from which to calculate it? *) + | name, Active ({ rd_prev_info = Some prev_info } as rd) -> + let cpu_time = + Int64.to_float (rd.rd_info.D.cpu_time -^ prev_info.D.cpu_time) in + let percent_cpu = 100. *. cpu_time /. total_cpu in + let mem_usage = rd.rd_info.D.memory in + let mem_percent = + 100L *^ rd.rd_info.D.memory /^ node_info.C.memory in + let rd = { rd with + rd_cpu_time = cpu_time; + rd_percent_cpu = percent_cpu; + rd_mem_bytes = mem_usage; + rd_mem_percent = mem_percent} in + name, Active rd + (* For all other domains we can't calculate it, so leave as 0 *) + | rd -> rd + ) doms in + + (* Calculate the number of block device read/write requests across + * all block devices attached to a domain. + *) + let doms = + List.map ( + function + (* Do we have stats from the previous slice? *) + | name, Active ({ rd_prev_block_stats = ((_::_) as prev_block_stats) } + as rd) -> + let block_stats = rd.rd_block_stats in (* stats now *) + + (* Add all the devices together. Throw away device names. *) + let prev_block_stats = + sum_block_stats (List.map snd prev_block_stats) in + let block_stats = + sum_block_stats (List.map snd block_stats) in + + (* Calculate increase in read & write requests. *) + let read_reqs = + block_stats.D.rd_req -^ prev_block_stats.D.rd_req in + let write_reqs = + block_stats.D.wr_req -^ prev_block_stats.D.wr_req in + let read_bytes = + block_stats.D.rd_bytes -^ prev_block_stats.D.rd_bytes in + let write_bytes = + block_stats.D.wr_bytes -^ prev_block_stats.D.wr_bytes in + + let rd = { rd with + rd_block_rd_reqs = Some read_reqs; + rd_block_wr_reqs = Some write_reqs; + rd_block_rd_bytes = Some read_bytes; + rd_block_wr_bytes = Some write_bytes; + } in + let rd = { rd with + rd_block_rd_info = + if block_in_bytes then + rd.rd_block_rd_bytes else rd.rd_block_rd_reqs; + rd_block_wr_info = + if block_in_bytes then + rd.rd_block_wr_bytes else rd.rd_block_wr_reqs; + } in + name, Active rd + (* For all other domains we can't calculate it, so leave as None. *) + | rd -> rd + ) doms in + + (* Calculate the same as above for network interfaces across + * all network interfaces attached to a domain. + *) + let doms = + List.map ( + function + (* Do we have stats from the previous slice? *) + | name, Active ({ rd_prev_interface_stats = + ((_::_) as prev_interface_stats) } + as rd) -> + let interface_stats = rd.rd_interface_stats in (* stats now *) + + (* Add all the devices together. Throw away device names. *) + let prev_interface_stats = + sum_interface_stats (List.map snd prev_interface_stats) in + let interface_stats = + sum_interface_stats (List.map snd interface_stats) in + + (* Calculate increase in rx & tx bytes. *) + let rx_bytes = + interface_stats.D.rx_bytes -^ prev_interface_stats.D.rx_bytes in + let tx_bytes = + interface_stats.D.tx_bytes -^ prev_interface_stats.D.tx_bytes in + + let rd = { rd with + rd_net_rx_bytes = Some rx_bytes; + rd_net_tx_bytes = Some tx_bytes } in + name, Active rd + (* For all other domains we can't calculate it, so leave as None. *) + | rd -> rd + ) doms in + + (* Calculate totals. *) + let totals = + List.fold_left ( + fun (count, running, blocked, paused, shutdown, shutoff, + crashed, active, inactive, + total_cpu_time, total_memory, total_domU_memory) -> + function + | (name, Active rd) -> + let test state orig = + if rd.rd_info.D.state = state then orig+1 else orig + in + let running = test D.InfoRunning running in + let blocked = test D.InfoBlocked blocked in + let paused = test D.InfoPaused paused in + let shutdown = test D.InfoShutdown shutdown in + let shutoff = test D.InfoShutoff shutoff in + let crashed = test D.InfoCrashed crashed in + + let total_cpu_time = total_cpu_time +. rd.rd_cpu_time in + let total_memory = total_memory +^ rd.rd_info.D.memory in + let total_domU_memory = + total_domU_memory +^ + if rd.rd_domid > 0 then rd.rd_info.D.memory else 0L in + + (count+1, running, blocked, paused, shutdown, shutoff, + crashed, active+1, inactive, + total_cpu_time, total_memory, total_domU_memory) + + | (name, Inactive) -> (* inactive domain *) + (count+1, running, blocked, paused, shutdown, shutoff, + crashed, active, inactive+1, + total_cpu_time, total_memory, total_domU_memory) + ) (0,0,0,0,0,0,0,0,0, 0.,0L,0L) doms in + + (* Update last_time, last_info. *) + last_time := time; + Hashtbl.clear last_info; + List.iter ( + function + | (_, Active rd) -> + let info = rd.rd_info, rd.rd_block_stats, rd.rd_interface_stats in + Hashtbl.add last_info rd.rd_domid info + | _ -> () + ) doms; + + { rd_doms = doms; + rd_time = time; + rd_printable_time = printable_time; + rd_nr_pcpus = nr_pcpus; + rd_total_cpu = total_cpu; + rd_total_cpu_per_pcpu = total_cpu_per_pcpu; + rd_totals = totals } + +(* Collect some extra information in PCPUDisplay display_mode. *) +let collect_pcpu { rd_doms = doms; rd_nr_pcpus = nr_pcpus } = + (* Get the VCPU info and VCPU->PCPU mappings for active domains. + * Also cull some data we don't care about. + *) + let doms = + List.filter_map ( + function + | (name, Active rd) -> + (try + let domid = rd.rd_domid in + let maplen = C.cpumaplen nr_pcpus in + let cpu_stats = D.get_cpu_stats rd.rd_dom in + + (* Note the terminology is confusing. + * + * In libvirt, cpu_time is the total time (hypervisor + + * vCPU). vcpu_time is the time only taken by the vCPU, + * excluding time taken inside the hypervisor. + * + * For each pCPU, libvirt may return either "cpu_time" + * or "vcpu_time" or neither or both. This function + * returns an array pair [|cpu_time, vcpu_time|]; + * if either is missing it is returned as 0. + *) + let find_cpu_usages params = + let rec find_uint64_field name = function + | (n, D.TypedFieldUInt64 usage) :: _ when n = name -> + usage + | _ :: params -> find_uint64_field name params + | [] -> 0L + in + [| find_uint64_field "cpu_time" params; + find_uint64_field "vcpu_time" params |] + in + + let pcpu_usages = Array.map find_cpu_usages cpu_stats in + let maxinfo = rd.rd_info.D.nr_virt_cpu in + let nr_vcpus, vcpu_infos, cpumaps = + D.get_vcpus rd.rd_dom maxinfo maplen in + + (* Got previous pcpu_usages for this domain? *) + let prev_pcpu_usages = + try Some (Hashtbl.find last_pcpu_usages domid) + with Not_found -> None in + (* Update last_pcpu_usages. *) + Hashtbl.replace last_pcpu_usages domid pcpu_usages; + + (match prev_pcpu_usages with + | Some prev_pcpu_usages + when Array.length prev_pcpu_usages = Array.length pcpu_usages -> + Some (domid, name, nr_vcpus, vcpu_infos, pcpu_usages, + prev_pcpu_usages, cpumaps, maplen) + | _ -> None (* ignore missing / unequal length prev_vcpu_infos *) + ); + with + Libvirt.Virterror _ -> None (* ignore transient libvirt errors *) + ) + | (_, Inactive) -> None (* ignore inactive doms *) + ) doms in + let nr_doms = List.length doms in + + (* Rearrange the data into a matrix. Major axis (down) is + * pCPUs. Minor axis (right) is domains. At each node we store: + * cpu_time hypervisor + domain (on this pCPU only, nanosecs), + * vcpu_time domain only (on this pCPU only, nanosecs). + *) + let make_3d_array dimx dimy dimz e = + Array.init dimx (fun _ -> Array.make_matrix dimy dimz e) + in + let pcpus = make_3d_array nr_pcpus nr_doms 2 0L in + + List.iteri ( + fun di (domid, name, nr_vcpus, vcpu_infos, pcpu_usages, + prev_pcpu_usages, cpumaps, maplen) -> + (* Which pCPUs can this dom run on? *) + for p = 0 to Array.length pcpu_usages - 1 do + pcpus.(p).(di).(0) <- + pcpu_usages.(p).(0) -^ prev_pcpu_usages.(p).(0); + pcpus.(p).(di).(1) <- + pcpu_usages.(p).(1) -^ prev_pcpu_usages.(p).(1) + done + ) doms; + + (* Sum the total CPU time used by each pCPU, for the %CPU column. *) + let pcpus_cpu_time = + Array.map ( + fun row -> + let cpu_time = ref 0L in + for di = 0 to Array.length row-1 do + let t = row.(di).(0) in + cpu_time := !cpu_time +^ t + done; + Int64.to_float !cpu_time + ) pcpus in + + { rd_pcpu_doms = doms; + rd_pcpu_pcpus = pcpus; + rd_pcpu_pcpus_cpu_time = pcpus_cpu_time } diff --git a/src/collect.mli b/src/collect.mli new file mode 100644 index 0000000..440859b --- /dev/null +++ b/src/collect.mli @@ -0,0 +1,86 @@ +(* 'top'-like tool for libvirt domains. + (C) Copyright 2007-2017 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. +*) + +(* Hook for [Opt_xml] to override (if present). *) +val parse_device_xml : + (int -> [ `R ] Libvirt.Domain.t -> string list * string list) ref + +(* Intermediate "domain + stats" structure that we use to collect + * everything we know about a domain within the collect function. + *) +type rd_domain = Inactive | Active of rd_active +and rd_active = { + rd_domid : int; (* Domain ID. *) + rd_dom : [`R] Libvirt.Domain.t; (* Domain object. *) + rd_info : Libvirt.Domain.info; (* Domain CPU info now. *) + rd_block_stats : (string * Libvirt.Domain.block_stats) list; + (* Domain block stats now. *) + rd_interface_stats : (string * Libvirt.Domain.interface_stats) list; + (* Domain net stats now. *) + rd_prev_info : Libvirt.Domain.info option; (* Domain CPU info previously. *) + rd_prev_block_stats : (string * Libvirt.Domain.block_stats) list; + (* Domain block stats prev. *) + rd_prev_interface_stats : (string * Libvirt.Domain.interface_stats) list; + (* Domain interface stats prev. *) + (* The following are since the last slice, or 0 if cannot be calculated: *) + rd_cpu_time : float; (* CPU time used in nanoseconds. *) + rd_percent_cpu : float; (* CPU time as percent of total. *) + rd_mem_bytes : int64; (* Memory usage in bytes *) + rd_mem_percent: int64; (* Memory usage as percent of total *) + (* The following are since the last slice, or None if cannot be calc'd: *) + rd_block_rd_reqs : int64 option; (* Number of block device read rqs. *) + rd_block_wr_reqs : int64 option; (* Number of block device write rqs. *) + rd_block_rd_bytes : int64 option; (* Number of bytes block device read *) + rd_block_wr_bytes : int64 option; (* Number of bytes block device write *) + (* _info fields includes the number considering --block_in_bytes option *) + rd_block_rd_info : int64 option; (* Block device read info for user *) + rd_block_wr_info : int64 option; (* Block device read info for user *) + + rd_net_rx_bytes : int64 option; (* Number of bytes received. *) + rd_net_tx_bytes : int64 option; (* Number of bytes transmitted. *) +} + +type stats = { + rd_doms : (string * rd_domain) list; (* List of domains. *) + rd_time : float; + rd_printable_time : string; + rd_nr_pcpus : int; + rd_total_cpu : float; + rd_total_cpu_per_pcpu : float; + rd_totals : (int * int * int * int * int * int * int * int * int * float * + int64 * int64); +} + +type pcpu_stats = { + rd_pcpu_doms : (int * string * int * + Libvirt.Domain.vcpu_info array * int64 array array * + int64 array array * string * int) list; + rd_pcpu_pcpus : int64 array array array; + rd_pcpu_pcpus_cpu_time : float array +} + +val collect : Types.setup -> bool -> stats +(** Collect statistics. *) + +val collect_pcpu : stats -> pcpu_stats +(** Used in PCPUDisplay mode only, this returns extra per-PCPU stats. *) + +val clear_pcpu_display_data : unit -> unit +(** Clear the cache of pcpu_usages used by PCPUDisplay display_mode + when we switch back to TaskDisplay mode. *) diff --git a/src/csv_output.ml b/src/csv_output.ml new file mode 100644 index 0000000..9496ca8 --- /dev/null +++ b/src/csv_output.ml @@ -0,0 +1,118 @@ +(* 'top'-like tool for libvirt domains. + (C) Copyright 2007-2017 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. +*) + +(* CSV output functions. *) + +open Printf +open ExtList + +open Collect + +module C = Libvirt.Connect + +(* Hook for CSV support (see [opt_csv.ml]). *) +let csv_write : (string list -> unit) ref = + ref ( + fun _ -> () + ) + +(* Write CSV header row. *) +let write_csv_header (csv_cpu, csv_mem, csv_block, csv_net) block_in_bytes = + (!csv_write) ( + [ "Hostname"; "Time"; "Arch"; "Physical CPUs"; + "Count"; "Running"; "Blocked"; "Paused"; "Shutdown"; + "Shutoff"; "Crashed"; "Active"; "Inactive"; + "%CPU"; + "Total hardware memory (KB)"; + "Total memory (KB)"; "Total guest memory (KB)"; + "Total CPU time (ns)" ] @ + (* These fields are repeated for each domain: *) + [ "Domain ID"; "Domain name"; ] @ + (if csv_cpu then [ "CPU (ns)"; "%CPU"; ] else []) @ + (if csv_mem then [ "Mem (bytes)"; "%Mem";] else []) @ + (if csv_block && not block_in_bytes + then [ "Block RDRQ"; "Block WRRQ"; ] else []) @ + (if csv_block && block_in_bytes + then [ "Block RDBY"; "Block WRBY"; ] else []) @ + (if csv_net then [ "Net RXBY"; "Net TXBY" ] else []) + ) + +(* Write summary data to CSV file. *) +let append_csv (_, _, _, _, _, node_info, hostname, _) (* setup *) + (csv_cpu, csv_mem, csv_block, csv_net) + { rd_doms = doms; + rd_printable_time = printable_time; + rd_nr_pcpus = nr_pcpus; rd_total_cpu = total_cpu; + rd_totals = totals } (* state *) = + (* The totals / summary fields. *) + let (count, running, blocked, paused, shutdown, shutoff, + crashed, active, inactive, + total_cpu_time, total_memory, total_domU_memory) = totals in + + let percent_cpu = 100. *. total_cpu_time /. total_cpu in + + let summary_fields = [ + hostname; printable_time; node_info.C.model; string_of_int nr_pcpus; + string_of_int count; string_of_int running; string_of_int blocked; + string_of_int paused; string_of_int shutdown; string_of_int shutoff; + string_of_int crashed; string_of_int active; string_of_int inactive; + sprintf "%2.1f" percent_cpu; + Int64.to_string node_info.C.memory; + Int64.to_string total_memory; Int64.to_string total_domU_memory; + Int64.to_string (Int64.of_float total_cpu_time) + ] in + + (* The domains. + * + * Sort them by ID so that the list of relatively stable. Ignore + * inactive domains. + *) + let doms = List.filter_map ( + function + | _, Inactive -> None (* Ignore inactive domains. *) + | name, Active rd -> Some (name, rd) + ) doms in + let cmp (_, { rd_domid = rd_domid1 }) (_, { rd_domid = rd_domid2 }) = + compare rd_domid1 rd_domid2 + in + let doms = List.sort ~cmp doms in + + let string_of_int64_option = Option.map_default Int64.to_string "" in + + let domain_fields = List.map ( + fun (domname, rd) -> + [ string_of_int rd.rd_domid; domname ] @ + (if csv_cpu then [ + string_of_float rd.rd_cpu_time; string_of_float rd.rd_percent_cpu + ] else []) @ + (if csv_mem then [ + Int64.to_string rd.rd_mem_bytes; Int64.to_string rd.rd_mem_percent + ] else []) @ + (if csv_block then [ + string_of_int64_option rd.rd_block_rd_info; + string_of_int64_option rd.rd_block_wr_info; + ] else []) @ + (if csv_net then [ + string_of_int64_option rd.rd_net_rx_bytes; + string_of_int64_option rd.rd_net_tx_bytes; + ] else []) + ) doms in + let domain_fields = List.flatten domain_fields in + + (!csv_write) (summary_fields @ domain_fields) diff --git a/src/csv_output.mli b/src/csv_output.mli new file mode 100644 index 0000000..d5eab0f --- /dev/null +++ b/src/csv_output.mli @@ -0,0 +1,27 @@ +(* 'top'-like tool for libvirt domains. + (C) Copyright 2007-2017 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. +*) + +(** CSV output functions. *) + +(* Hook for [Opt_csv] to override (if present). *) +val csv_write : (string list -> unit) ref + +val write_csv_header : bool * bool * bool * bool -> bool -> unit + +val append_csv : Types.setup -> bool * bool * bool * bool -> Collect.stats -> unit diff --git a/src/opt_csv.ml b/src/opt_csv.ml index 6c3b2be..6625c61 100644 --- a/src/opt_csv.ml +++ b/src/opt_csv.ml @@ -28,7 +28,7 @@ Top.csv_start := fun filename -> chan := Some (open_out filename) ;; -Top.csv_write := +Csv_output.csv_write := fun row -> match !chan with | None -> () (* CSV output not enabled. *) diff --git a/src/opt_xml.ml b/src/opt_xml.ml index bb83780..1037b85 100644 --- a/src/opt_xml.ml +++ b/src/opt_xml.ml @@ -27,7 +27,7 @@ module C = Libvirt.Connect module D = Libvirt.Domain module N = Libvirt.Network ;; -Top.parse_device_xml := +Collect.parse_device_xml := fun id dom -> try let xml = D.get_xml_desc dom in diff --git a/src/redraw.ml b/src/redraw.ml new file mode 100644 index 0000000..9ce889b --- /dev/null +++ b/src/redraw.ml @@ -0,0 +1,506 @@ +(* 'top'-like tool for libvirt domains. + (C) Copyright 2007-2017 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 ExtList +open Curses +open Printf + +open Opt_gettext.Gettext +open Utils +open Types +open Screen +open Collect + +module C = Libvirt.Connect +module D = Libvirt.Domain + +(* Keep a historical list of %CPU usages. *) +let historical_cpu = ref [] +let historical_cpu_last_time = ref (Unix.gettimeofday ()) + +(* Redraw the display. *) +let redraw display_mode sort_order + (_, _, _, _, _, node_info, _, _) (* setup *) + block_in_bytes + historical_cpu_delay + { rd_doms = doms; + rd_time = time; rd_printable_time = printable_time; + rd_nr_pcpus = nr_pcpus; + rd_total_cpu = total_cpu; + rd_total_cpu_per_pcpu = total_cpu_per_pcpu; + rd_totals = totals } (* state *) + pcpu_display = + clear (); + + (* Get the screen/window size. *) + let lines, cols = get_size () in + + (* Time. *) + mvaddstr top_lineno 0 (sprintf "virt-top %s - " printable_time); + + (* Basic node_info. *) + addstr + (sprintf "%s %d/%dCPU %dMHz %LdMB " + node_info.C.model node_info.C.cpus nr_pcpus node_info.C.mhz + (node_info.C.memory /^ 1024L)); + (* Save the cursor position for when we come to draw the + * historical CPU times (down in this function). + *) + let stdscr = stdscr () in + let historical_cursor = getyx stdscr in + + (match display_mode with + + (*---------- Showing domains ----------*) + | TaskDisplay -> + (* Sort domains on current sort_order. *) + let doms = + let cmp = + match sort_order with + | DomainName -> + (fun _ -> 0) (* fallthrough to default name compare *) + | Processor -> + (function + | Active rd1, Active rd2 -> + compare rd2.rd_percent_cpu rd1.rd_percent_cpu + | Active _, Inactive -> -1 + | Inactive, Active _ -> 1 + | Inactive, Inactive -> 0) + | Memory -> + (function + | Active { rd_info = info1 }, Active { rd_info = info2 } -> + compare info2.D.memory info1.D.memory + | Active _, Inactive -> -1 + | Inactive, Active _ -> 1 + | Inactive, Inactive -> 0) + | Time -> + (function + | Active { rd_info = info1 }, Active { rd_info = info2 } -> + compare info2.D.cpu_time info1.D.cpu_time + | Active _, Inactive -> -1 + | Inactive, Active _ -> 1 + | Inactive, Inactive -> 0) + | DomainID -> + (function + | Active { rd_domid = id1 }, Active { rd_domid = id2 } -> + compare id1 id2 + | Active _, Inactive -> -1 + | Inactive, Active _ -> 1 + | Inactive, Inactive -> 0) + | NetRX -> + (function + | Active { rd_net_rx_bytes = r1 }, Active { rd_net_rx_bytes = r2 } -> + compare r2 r1 + | Active _, Inactive -> -1 + | Inactive, Active _ -> 1 + | Inactive, Inactive -> 0) + | NetTX -> + (function + | Active { rd_net_tx_bytes = r1 }, Active { rd_net_tx_bytes = r2 } -> + compare r2 r1 + | Active _, Inactive -> -1 + | Inactive, Active _ -> 1 + | Inactive, Inactive -> 0) + | BlockRdRq -> + (function + | Active { rd_block_rd_reqs = r1 }, Active { rd_block_rd_reqs = r2 } -> + compare r2 r1 + | Active _, Inactive -> -1 + | Inactive, Active _ -> 1 + | Inactive, Inactive -> 0) + | BlockWrRq -> + (function + | Active { rd_block_wr_reqs = r1 }, Active { rd_block_wr_reqs = r2 } -> + compare r2 r1 + | Active _, Inactive -> -1 + | Inactive, Active _ -> 1 + | Inactive, Inactive -> 0) + in + let cmp (name1, dom1) (name2, dom2) = + let r = cmp (dom1, dom2) in + if r <> 0 then r + else compare name1 name2 + in + List.sort ~cmp doms in + + (* Print domains. *) + attron A.reverse; + let header_string = + if block_in_bytes + then " ID S RDBY WRBY RXBY TXBY %CPU %MEM TIME NAME" + else " ID S RDRQ WRRQ RXBY TXBY %CPU %MEM TIME NAME" + in + mvaddstr header_lineno 0 + (pad cols header_string); + attroff A.reverse; + + let rec loop lineno = function + | [] -> () + | (name, Active rd) :: doms -> + if lineno < lines then ( + let state = show_state rd.rd_info.D.state in + let rd_req = Show.int64_option rd.rd_block_rd_info in + let wr_req = Show.int64_option rd.rd_block_wr_info in + let rx_bytes = Show.int64_option rd.rd_net_rx_bytes in + let tx_bytes = Show.int64_option rd.rd_net_tx_bytes in + let percent_cpu = Show.percent rd.rd_percent_cpu in + let percent_mem = Int64.to_float rd.rd_mem_percent in + let percent_mem = Show.percent percent_mem in + let time = Show.time rd.rd_info.D.cpu_time in + + let line = + sprintf "%5d %c %s %s %s %s %s %s %s %s" + rd.rd_domid state rd_req wr_req rx_bytes tx_bytes + percent_cpu percent_mem time name in + let line = pad cols line in + mvaddstr lineno 0 line; + loop (lineno+1) doms + ) + | (name, Inactive) :: doms -> (* inactive domain *) + if lineno < lines then ( + let line = + sprintf + " - (%s)" + name in + let line = pad cols line in + mvaddstr lineno 0 line; + loop (lineno+1) doms + ) + in + loop domains_lineno doms + + (*---------- Showing physical CPUs ----------*) + | PCPUDisplay -> + let { rd_pcpu_doms = doms; + rd_pcpu_pcpus = pcpus; + rd_pcpu_pcpus_cpu_time = pcpus_cpu_time } = + match pcpu_display with + | Some p -> p + | None -> failwith "internal error: no pcpu_display data" in + + (* Display the pCPUs. *) + let dom_names = + String.concat "" ( + List.map ( + fun (_, name, _, _, _, _, _, _) -> + let len = String.length name in + let width = max (len+1) 12 in + pad width name + ) doms + ) in + attron A.reverse; + mvaddstr header_lineno 0 (pad cols ("PHYCPU %CPU " ^ dom_names)); + attroff A.reverse; + + Array.iteri ( + fun p row -> + mvaddstr (p+domains_lineno) 0 (sprintf "%4d " p); + let cpu_time = pcpus_cpu_time.(p) in (* ns used on this CPU *) + let percent_cpu = 100. *. cpu_time /. total_cpu_per_pcpu in + addstr (Show.percent percent_cpu); + addch ' '; + + List.iteri ( + fun di (domid, name, _, _, _, _, _, _) -> + let t = pcpus.(p).(di).(0) in (* hypervisor + domain *) + let t_only = pcpus.(p).(di).(1) in (* domain only *) + let len = String.length name in + let width = max (len+1) 12 in + let str_t = + if t <= 0L then "" + else ( + let t = Int64.to_float t in + let percent = 100. *. t /. total_cpu_per_pcpu in + Show.percent percent + ) in + let str_t_only = + if t_only <= 0L then "" + else ( + let t_only = Int64.to_float t_only in + let percent = 100. *. t_only /. total_cpu_per_pcpu in + Show.percent percent + ) in + addstr (pad 5 str_t); + addstr (pad 5 str_t_only); + addstr (pad (width-10) " "); + () + ) doms + ) pcpus; + + (*---------- Showing network interfaces ----------*) + | NetDisplay -> + (* Only care about active domains. *) + let doms = + List.filter_map ( + function + | (name, Active rd) -> Some (name, rd) + | (_, Inactive) -> None + ) doms in + + (* For each domain we have a list of network interfaces seen + * this slice, and seen in the previous slice, which we now + * match up to get a list of (domain, interface) for which + * we have current & previous knowledge. (And ignore the rest). + *) + let devs = + List.map ( + fun (name, rd) -> + List.filter_map ( + fun (dev, stats) -> + try + (* Have prev slice stats for this device? *) + let prev_stats = + List.assoc dev rd.rd_prev_interface_stats in + Some (dev, name, rd, stats, prev_stats) + with Not_found -> None + ) rd.rd_interface_stats + ) doms in + + (* Finally we have a list of: + * device name, domain name, rd_* stuff, curr stats, prev stats. + *) + let devs : (string * string * rd_active * + D.interface_stats * D.interface_stats) list = + List.flatten devs in + + (* Difference curr slice & prev slice. *) + let devs = + List.map ( + fun (dev, name, rd, curr, prev) -> + dev, name, rd, diff_interface_stats curr prev + ) devs in + + (* Sort by current sort order, but map some of the standard + * sort orders into ones which makes sense here. + *) + let devs = + let cmp = + match sort_order with + | DomainName -> + (fun _ -> 0) (* fallthrough to default name compare *) + | DomainID -> + (fun (_, { rd_domid = id1 }, _, { rd_domid = id2 }) -> + compare id1 id2) + | Processor | Memory | Time + | BlockRdRq | BlockWrRq + (* fallthrough to RXBY comparison. *) + | NetRX -> + (fun ({ D.rx_bytes = b1 }, _, { D.rx_bytes = b2 }, _) -> + compare b2 b1) + | NetTX -> + (fun ({ D.tx_bytes = b1 }, _, { D.tx_bytes = b2 }, _) -> + compare b2 b1) + in + let cmp (dev1, name1, rd1, stats1) (dev2, name2, rd2, stats2) = + let r = cmp (stats1, rd1, stats2, rd2) in + if r <> 0 then r + else compare (dev1, name1) (dev2, name2) + in + List.sort ~cmp devs in + + (* Print the header for network devices. *) + attron A.reverse; + mvaddstr header_lineno 0 + (pad cols " ID S RXBY TXBY RXPK TXPK DOMAIN INTERFACE"); + attroff A.reverse; + + (* Print domains and devices. *) + let rec loop lineno = function + | [] -> () + | (dev, name, rd, stats) :: devs -> + if lineno < lines then ( + let state = show_state rd.rd_info.D.state in + let rx_bytes = + if stats.D.rx_bytes >= 0L + then Show.int64 stats.D.rx_bytes + else " " in + let tx_bytes = + if stats.D.tx_bytes >= 0L + then Show.int64 stats.D.tx_bytes + else " " in + let rx_packets = + if stats.D.rx_packets >= 0L + then Show.int64 stats.D.rx_packets + else " " in + let tx_packets = + if stats.D.tx_packets >= 0L + then Show.int64 stats.D.tx_packets + else " " in + + let line = sprintf "%5d %c %s %s %s %s %-12s %s" + rd.rd_domid state + rx_bytes tx_bytes + rx_packets tx_packets + (pad 12 name) dev in + let line = pad cols line in + mvaddstr lineno 0 line; + loop (lineno+1) devs + ) + in + loop domains_lineno devs + + (*---------- Showing block devices ----------*) + | BlockDisplay -> + (* Only care about active domains. *) + let doms = + List.filter_map ( + function + | (name, Active rd) -> Some (name, rd) + | (_, Inactive) -> None + ) doms in + + (* For each domain we have a list of block devices seen + * this slice, and seen in the previous slice, which we now + * match up to get a list of (domain, device) for which + * we have current & previous knowledge. (And ignore the rest). + *) + let devs = + List.map ( + fun (name, rd) -> + List.filter_map ( + fun (dev, stats) -> + try + (* Have prev slice stats for this device? *) + let prev_stats = + List.assoc dev rd.rd_prev_block_stats in + Some (dev, name, rd, stats, prev_stats) + with Not_found -> None + ) rd.rd_block_stats + ) doms in + + (* Finally we have a list of: + * device name, domain name, rd_* stuff, curr stats, prev stats. + *) + let devs : (string * string * rd_active * + D.block_stats * D.block_stats) list = + List.flatten devs in + + (* Difference curr slice & prev slice. *) + let devs = + List.map ( + fun (dev, name, rd, curr, prev) -> + dev, name, rd, diff_block_stats curr prev + ) devs in + + (* Sort by current sort order, but map some of the standard + * sort orders into ones which makes sense here. + *) + let devs = + let cmp = + match sort_order with + | DomainName -> + (fun _ -> 0) (* fallthrough to default name compare *) + | DomainID -> + (fun (_, { rd_domid = id1 }, _, { rd_domid = id2 }) -> + compare id1 id2) + | Processor | Memory | Time + | NetRX | NetTX + (* fallthrough to RDRQ comparison. *) + | BlockRdRq -> + (fun ({ D.rd_req = b1 }, _, { D.rd_req = b2 }, _) -> + compare b2 b1) + | BlockWrRq -> + (fun ({ D.wr_req = b1 }, _, { D.wr_req = b2 }, _) -> + compare b2 b1) + in + let cmp (dev1, name1, rd1, stats1) (dev2, name2, rd2, stats2) = + let r = cmp (stats1, rd1, stats2, rd2) in + if r <> 0 then r + else compare (dev1, name1) (dev2, name2) + in + List.sort ~cmp devs in + + (* Print the header for block devices. *) + attron A.reverse; + mvaddstr header_lineno 0 + (pad cols " ID S RDBY WRBY RDRQ WRRQ DOMAIN DEVICE"); + attroff A.reverse; + + (* Print domains and devices. *) + let rec loop lineno = function + | [] -> () + | (dev, name, rd, stats) :: devs -> + if lineno < lines then ( + let state = show_state rd.rd_info.D.state in + let rd_bytes = + if stats.D.rd_bytes >= 0L + then Show.int64 stats.D.rd_bytes + else " " in + let wr_bytes = + if stats.D.wr_bytes >= 0L + then Show.int64 stats.D.wr_bytes + else " " in + let rd_req = + if stats.D.rd_req >= 0L + then Show.int64 stats.D.rd_req + else " " in + let wr_req = + if stats.D.wr_req >= 0L + then Show.int64 stats.D.wr_req + else " " in + + let line = sprintf "%5d %c %s %s %s %s %-12s %s" + rd.rd_domid state + rd_bytes wr_bytes + rd_req wr_req + (pad 12 name) dev in + let line = pad cols line in + mvaddstr lineno 0 line; + loop (lineno+1) devs + ) + in + loop domains_lineno devs + ); (* end of display_mode conditional section *) + + let (count, running, blocked, paused, shutdown, shutoff, + crashed, active, inactive, + total_cpu_time, total_memory, total_domU_memory) = totals in + + mvaddstr summary_lineno 0 + (sprintf + (f_"%d domains, %d active, %d running, %d sleeping, %d paused, %d inactive D:%d O:%d X:%d") + count active running blocked paused inactive shutdown shutoff crashed); + + (* Total %CPU used, and memory summary. *) + let percent_cpu = 100. *. total_cpu_time /. total_cpu in + mvaddstr (summary_lineno+1) 0 + (sprintf + (f_"CPU: %2.1f%% Mem: %Ld MB (%Ld MB by guests)") + percent_cpu (total_memory /^ 1024L) (total_domU_memory /^ 1024L)); + + (* Time to grab another historical %CPU for the list? *) + if time >= !historical_cpu_last_time +. float historical_cpu_delay + then ( + historical_cpu := percent_cpu :: List.take 10 !historical_cpu; + historical_cpu_last_time := time + ); + + (* Display historical CPU time. *) + let () = + let y, x = historical_cursor in + let maxwidth = cols - x in + let line = + String.concat " " + (List.map (sprintf "%2.1f%%") !historical_cpu) in + let line = pad maxwidth line in + mvaddstr y x line; + () in + + move message_lineno 0; (* Park cursor in message area, as with top. *) + refresh () (* Refresh the display. *) diff --git a/src/redraw.mli b/src/redraw.mli new file mode 100644 index 0000000..2ea97c3 --- /dev/null +++ b/src/redraw.mli @@ -0,0 +1,20 @@ +(* 'top'-like tool for libvirt domains. + (C) Copyright 2007-2017 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. +*) + +val redraw : Types.display -> Types.sort_order -> Types.setup -> bool -> int -> Collect.stats -> Collect.pcpu_stats option -> unit diff --git a/src/screen.ml b/src/screen.ml new file mode 100644 index 0000000..0d847a2 --- /dev/null +++ b/src/screen.ml @@ -0,0 +1,52 @@ +(* 'top'-like tool for libvirt domains. + (C) Copyright 2007-2017 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. +*) + +(* The virt-top screen layout. *) + +open Curses + +module D = Libvirt.Domain + +(* Line numbers. *) +let top_lineno = 0 +let summary_lineno = 1 (* this takes 2 lines *) +let message_lineno = 3 +let header_lineno = 4 +let domains_lineno = 5 + +(* Easier to use versions of curses functions addstr, mvaddstr, etc. *) +let move y x = ignore (move y x) +let refresh () = ignore (refresh ()) +let addch c = ignore (addch (int_of_char c)) +let addstr s = ignore (addstr s) +let mvaddstr y x s = ignore (mvaddstr y x s) + +(* Print in the "message area". *) +let clear_msg () = move message_lineno 0; clrtoeol () +let print_msg str = clear_msg (); mvaddstr message_lineno 0 str + +(* Show a libvirt domain state (the 'S' column). *) +let show_state = function + | D.InfoNoState -> '?' + | D.InfoRunning -> 'R' + | D.InfoBlocked -> 'S' + | D.InfoPaused -> 'P' + | D.InfoShutdown -> 'D' + | D.InfoShutoff -> 'O' + | D.InfoCrashed -> 'X' diff --git a/src/screen.mli b/src/screen.mli new file mode 100644 index 0000000..a8a23a0 --- /dev/null +++ b/src/screen.mli @@ -0,0 +1,41 @@ +(* 'top'-like tool for libvirt domains. + (C) Copyright 2007-2017 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. +*) + +(** The virt-top screen layout. *) + +(* Line numbers. *) +val top_lineno : int +val summary_lineno : int (** this takes 2 lines *) +val message_lineno : int +val header_lineno : int +val domains_lineno : int + +(* Easier to use versions of curses functions addstr, mvaddstr, etc. *) +val move : int -> int -> unit +val refresh : unit -> unit +val addch : char -> unit +val addstr : string -> unit +val mvaddstr : int -> int -> string -> unit + +(* Print in the "message area". *) +val clear_msg : unit -> unit +val print_msg : string -> unit + +(* Show a libvirt domain state (the 'S' column). *) +val show_state : Libvirt.Domain.state -> char diff --git a/src/stream_output.ml b/src/stream_output.ml new file mode 100644 index 0000000..bf7b114 --- /dev/null +++ b/src/stream_output.ml @@ -0,0 +1,84 @@ +(* 'top'-like tool for libvirt domains. + (C) Copyright 2007-2017 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. +*) + +(* [--stream] mode output functions. *) + +open Printf +open ExtList + +open Utils +open Collect + +module C = Libvirt.Connect +module D = Libvirt.Domain + +let append_stream (_, _, _, _, _, node_info, hostname, _) (* setup *) + block_in_bytes + { rd_doms = doms; + rd_printable_time = printable_time; + rd_nr_pcpus = nr_pcpus; rd_total_cpu = total_cpu; + rd_totals = totals } (* state *) = + (* Header for this iteration *) + printf "virt-top time %s Host %s %s %d/%dCPU %dMHz %LdMB \n" + printable_time hostname node_info.C.model node_info.C.cpus nr_pcpus + node_info.C.mhz (node_info.C.memory /^ 1024L); + (* dump domain information one by one *) + let rd, wr = if block_in_bytes then "RDBY", "WRBY" else "RDRQ", "WRRQ" + in + printf " ID S %s %s RXBY TXBY %%CPU %%MEM TIME NAME\n" rd wr; + + (* sort by ID *) + let doms = + let compare = + (function + | Active {rd_domid = id1 }, Active {rd_domid = id2} -> + compare id1 id2 + | Active _, Inactive -> -1 + | Inactive, Active _ -> 1 + | Inactive, Inactive -> 0) + in + let cmp (name1, dom1) (name2, dom2) = compare(dom1, dom2) in + List.sort ~cmp doms in + (*Print domains *) + let dump_domain = fun name rd + -> begin + let state = Screen.show_state rd.rd_info.D.state in + let rd_req = if rd.rd_block_rd_info = None then " 0" + else Show.int64_option rd.rd_block_rd_info in + let wr_req = if rd.rd_block_wr_info = None then " 0" + else Show.int64_option rd.rd_block_wr_info in + let rx_bytes = if rd.rd_net_rx_bytes = None then " 0" + else Show.int64_option rd.rd_net_rx_bytes in + let tx_bytes = if rd.rd_net_tx_bytes = None then " 0" + else Show.int64_option rd.rd_net_tx_bytes in + let percent_cpu = Show.percent rd.rd_percent_cpu in + let percent_mem = Int64.to_float rd.rd_mem_percent in + let percent_mem = Show.percent percent_mem in + let time = Show.time rd.rd_info.D.cpu_time in + printf "%5d %c %s %s %s %s %s %s %s %s\n" + rd.rd_domid state rd_req wr_req rx_bytes tx_bytes + percent_cpu percent_mem time name; + end + in + List.iter ( + function + | name, Active dom -> dump_domain name dom + | name, Inactive -> () + ) doms; + flush stdout diff --git a/src/stream_output.mli b/src/stream_output.mli new file mode 100644 index 0000000..c45e548 --- /dev/null +++ b/src/stream_output.mli @@ -0,0 +1,22 @@ +(* 'top'-like tool for libvirt domains. + (C) Copyright 2007-2017 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. +*) + +(** [--stream] mode output functions. *) + +val append_stream : Types.setup -> bool -> Collect.stats -> unit diff --git a/src/top.ml b/src/top.ml index f50e6a8..204f3b6 100644 --- a/src/top.ml +++ b/src/top.ml @@ -1,5 +1,5 @@ (* 'top'-like tool for libvirt domains. - (C) Copyright 2007-2009 Richard W.M. Jones, Red Hat Inc. + (C) Copyright 2007-2017 Richard W.M. Jones, Red Hat Inc. http://libvirt.org/ This program is free software; you can redistribute it and/or modify @@ -23,6 +23,9 @@ open Curses open Opt_gettext.Gettext open Utils +open Types +open Collect +open Screen module C = Libvirt.Connect module D = Libvirt.Domain @@ -30,21 +33,11 @@ module N = Libvirt.Network let rcfile = ".virt-toprc" -(* Hook for XML support (see [opt_xml.ml]). *) -let parse_device_xml : (int -> [>`R] D.t -> string list * string list) ref = - ref ( - fun _ _ -> [], [] - ) - (* Hooks for CSV support (see [opt_csv.ml]). *) let csv_start : (string -> unit) ref = ref ( fun _ -> failwith (s_"virt-top was compiled without support for CSV files") ) -let csv_write : (string list -> unit) ref = - ref ( - fun _ -> () - ) (* Hook for calendar support (see [opt_calendar.ml]). *) let parse_date_time : (string -> float) ref = @@ -53,62 +46,6 @@ let parse_date_time : (string -> float) ref = failwith (s_"virt-top was compiled without support for dates and times") ) -(* Sort order. *) -type sort_order = - | DomainID | DomainName | Processor | Memory | Time - | NetRX | NetTX | BlockRdRq | BlockWrRq -let all_sort_fields = [ - DomainID; DomainName; Processor; Memory; Time; - NetRX; NetTX; BlockRdRq; BlockWrRq -] -let printable_sort_order = function - | Processor -> s_"%CPU" - | Memory -> s_"%MEM" - | Time -> s_"TIME (CPU time)" - | DomainID -> s_"Domain ID" - | DomainName -> s_"Domain name" - | NetRX -> s_"Net RX bytes" - | NetTX -> s_"Net TX bytes" - | BlockRdRq -> s_"Block read reqs" - | BlockWrRq -> s_"Block write reqs" -let sort_order_of_cli = function - | "cpu" | "processor" -> Processor - | "mem" | "memory" -> Memory - | "time" -> Time - | "id" -> DomainID - | "name" -> DomainName - | "netrx" -> NetRX | "nettx" -> NetTX - | "blockrdrq" -> BlockRdRq | "blockwrrq" -> BlockWrRq - | str -> - failwithf (f_"%s: sort order should be: %s") - str "cpu|mem|time|id|name|netrx|nettx|blockrdrq|blockwrrq" -let cli_of_sort_order = function - | Processor -> "cpu" - | Memory -> "mem" - | Time -> "time" - | DomainID -> "id" - | DomainName -> "name" - | NetRX -> "netrx" - | NetTX -> "nettx" - | BlockRdRq -> "blockrdrq" - | BlockWrRq -> "blockwrrq" - -(* Current major display mode: TaskDisplay is the normal display. *) -type display = TaskDisplay | PCPUDisplay | BlockDisplay | NetDisplay - -let display_of_cli = function - | "task" -> TaskDisplay - | "pcpu" -> PCPUDisplay - | "block" -> BlockDisplay - | "net" -> NetDisplay - | str -> - failwithf (f_"%s: display should be %s") str "task|pcpu|block|net" -let cli_of_display = function - | TaskDisplay -> "task" - | PCPUDisplay -> "pcpu" - | BlockDisplay -> "block" - | NetDisplay -> "net" - (* Init file. *) type init_file = NoInitFile | DefaultInitFile | InitFile of string @@ -134,11 +71,6 @@ let script_mode = ref false let stream_mode = ref false let block_in_bytes = ref false -(* Tuple of never-changing data returned by start_up function. *) -type setup = - Libvirt.ro C.t * bool * bool * bool * bool * C.node_info * string * - (int * int * int) - (* Function to read command line arguments and go into curses mode. *) let start_up () = (* Read command line arguments. *) @@ -352,16 +284,6 @@ OPTIONS" in node_info, hostname, libvirt_version (* info that doesn't change *) ) -(* Show a domain state (the 'S' column). *) -let show_state = function - | D.InfoNoState -> '?' - | D.InfoRunning -> 'R' - | D.InfoBlocked -> 'S' - | D.InfoPaused -> 'P' - | D.InfoShutdown -> 'D' - | D.InfoShutoff -> 'O' - | D.InfoCrashed -> 'X' - (* Sleep in seconds. *) let sleep = Unix.sleep @@ -387,1039 +309,33 @@ let get_string maxlen = Not_found -> str (* it is full maxlen bytes *) ) -(* Line numbers. *) -let top_lineno = 0 -let summary_lineno = 1 (* this takes 2 lines *) -let message_lineno = 3 -let header_lineno = 4 -let domains_lineno = 5 - -(* Easier to use versions of curses functions addstr, mvaddstr, etc. *) -let move y x = ignore (move y x) -let refresh () = ignore (refresh ()) -let addch c = ignore (addch (int_of_char c)) -let addstr s = ignore (addstr s) -let mvaddstr y x s = ignore (mvaddstr y x s) - -(* Print in the "message area". *) -let clear_msg () = move message_lineno 0; clrtoeol () -let print_msg str = clear_msg (); mvaddstr message_lineno 0 str - -(* Intermediate "domain + stats" structure that we use to collect - * everything we know about a domain within the collect function. - *) -type rd_domain = Inactive | Active of rd_active -and rd_active = { - rd_domid : int; (* Domain ID. *) - rd_dom : [`R] D.t; (* Domain object. *) - rd_info : D.info; (* Domain CPU info now. *) - rd_block_stats : (string * D.block_stats) list; - (* Domain block stats now. *) - rd_interface_stats : (string * D.interface_stats) list; - (* Domain net stats now. *) - rd_prev_info : D.info option; (* Domain CPU info previously. *) - rd_prev_block_stats : (string * D.block_stats) list; - (* Domain block stats prev. *) - rd_prev_interface_stats : (string * D.interface_stats) list; - (* Domain interface stats prev. *) - (* The following are since the last slice, or 0 if cannot be calculated: *) - rd_cpu_time : float; (* CPU time used in nanoseconds. *) - rd_percent_cpu : float; (* CPU time as percent of total. *) - rd_mem_bytes : int64; (* Memory usage in bytes *) - rd_mem_percent: int64; (* Memory usage as percent of total *) - (* The following are since the last slice, or None if cannot be calc'd: *) - rd_block_rd_reqs : int64 option; (* Number of block device read rqs. *) - rd_block_wr_reqs : int64 option; (* Number of block device write rqs. *) - rd_block_rd_bytes : int64 option; (* Number of bytes block device read *) - rd_block_wr_bytes : int64 option; (* Number of bytes block device write *) - (* _info fields includes the number considering --block_in_bytes option *) - rd_block_rd_info : int64 option; (* Block device read info for user *) - rd_block_wr_info : int64 option; (* Block device read info for user *) - - rd_net_rx_bytes : int64 option; (* Number of bytes received. *) - rd_net_tx_bytes : int64 option; (* Number of bytes transmitted. *) -} - -(* Collect stats. *) -let collect, clear_pcpu_display_data = - (* We cache the list of block devices and interfaces for each domain - * here, so we don't need to reparse the XML each time. - *) - let devices = Hashtbl.create 13 in - - (* Function to get the list of block devices, network interfaces for - * a particular domain. Get it from the devices cache, and if not - * there then parse the domain XML. - *) - let get_devices id dom = - try Hashtbl.find devices id - with Not_found -> - let blkdevs, netifs = (!parse_device_xml) id dom in - Hashtbl.replace devices id (blkdevs, netifs); - blkdevs, netifs - in - - (* We save the state of domains across redraws here, which allows us - * to deduce %CPU usage from the running total. - *) - let last_info = Hashtbl.create 13 in - let last_time = ref (Unix.gettimeofday ()) in - - (* Save pcpu_usages structures across redraws too (only for pCPU display). *) - let last_pcpu_usages = Hashtbl.create 13 in - - let clear_pcpu_display_data () = - (* Clear out pcpu_usages used by PCPUDisplay display_mode - * when we switch back to TaskDisplay mode. - *) - Hashtbl.clear last_pcpu_usages - in - - let collect (conn, _, _, _, _, node_info, _, _) = - (* Number of physical CPUs (some may be disabled). *) - let nr_pcpus = C.maxcpus_of_node_info node_info in - - (* Get the current time. *) - let time = Unix.gettimeofday () in - let tm = Unix.localtime time in - let printable_time = - sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in - - (* What's the total CPU time elapsed since we were last called? (ns) *) - let total_cpu_per_pcpu = 1_000_000_000. *. (time -. !last_time) in - (* Avoid division by zero. *) - let total_cpu_per_pcpu = - if total_cpu_per_pcpu <= 0. then 1. else total_cpu_per_pcpu in - let total_cpu = float node_info.C.cpus *. total_cpu_per_pcpu in - - (* Get the domains. Match up with their last_info (if any). *) - let doms = - (* Active domains. *) - let n = C.num_of_domains conn in - let ids = - if n > 0 then Array.to_list (C.list_domains conn n) - else [] in - let doms = - List.filter_map ( - fun id -> - try - let dom = D.lookup_by_id conn id in - let name = D.get_name dom in - let blkdevs, netifs = get_devices id dom in - - (* Get current CPU, block and network stats. *) - let info = D.get_info dom in - let block_stats = - try List.map (fun dev -> dev, D.block_stats dom dev) blkdevs - with - | Libvirt.Not_supported "virDomainBlockStats" - | Libvirt.Virterror _ -> [] in - let interface_stats = - try List.map (fun dev -> dev, D.interface_stats dom dev) netifs - with - | Libvirt.Not_supported "virDomainInterfaceStats" - | Libvirt.Virterror _ -> [] in - - let prev_info, prev_block_stats, prev_interface_stats = - try - let prev_info, prev_block_stats, prev_interface_stats = - Hashtbl.find last_info id in - Some prev_info, prev_block_stats, prev_interface_stats - with Not_found -> None, [], [] in - - Some (name, Active { - rd_domid = id; rd_dom = dom; rd_info = info; - rd_block_stats = block_stats; - rd_interface_stats = interface_stats; - rd_prev_info = prev_info; - rd_prev_block_stats = prev_block_stats; - rd_prev_interface_stats = prev_interface_stats; - rd_cpu_time = 0.; rd_percent_cpu = 0.; - rd_mem_bytes = 0L; rd_mem_percent = 0L; - rd_block_rd_reqs = None; rd_block_wr_reqs = None; - rd_block_rd_bytes = None; rd_block_wr_bytes = None; - rd_block_rd_info = None; rd_block_wr_info = None; - rd_net_rx_bytes = None; rd_net_tx_bytes = None; - }) - with - Libvirt.Virterror _ -> None (* ignore transient error *) - ) ids in - - (* Inactive domains. *) - let doms_inactive = - try - let n = C.num_of_defined_domains conn in - let names = - if n > 0 then Array.to_list (C.list_defined_domains conn n) - else [] in - List.map (fun name -> name, Inactive) names - with - (* Ignore transient errors, in particular errors from - * num_of_defined_domains if it cannot contact xend. - *) - | Libvirt.Virterror _ -> [] in - - doms @ doms_inactive in - - (* Calculate the CPU time (ns) and %CPU used by each domain. *) - let doms = - List.map ( - function - (* We have previous CPU info from which to calculate it? *) - | name, Active ({ rd_prev_info = Some prev_info } as rd) -> - let cpu_time = - Int64.to_float (rd.rd_info.D.cpu_time -^ prev_info.D.cpu_time) in - let percent_cpu = 100. *. cpu_time /. total_cpu in - let mem_usage = rd.rd_info.D.memory in - let mem_percent = - 100L *^ rd.rd_info.D.memory /^ node_info.C.memory in - let rd = { rd with - rd_cpu_time = cpu_time; - rd_percent_cpu = percent_cpu; - rd_mem_bytes = mem_usage; - rd_mem_percent = mem_percent} in - name, Active rd - (* For all other domains we can't calculate it, so leave as 0 *) - | rd -> rd - ) doms in - - (* Calculate the number of block device read/write requests across - * all block devices attached to a domain. - *) - let doms = - List.map ( - function - (* Do we have stats from the previous slice? *) - | name, Active ({ rd_prev_block_stats = ((_::_) as prev_block_stats) } - as rd) -> - let block_stats = rd.rd_block_stats in (* stats now *) - - (* Add all the devices together. Throw away device names. *) - let prev_block_stats = - sum_block_stats (List.map snd prev_block_stats) in - let block_stats = - sum_block_stats (List.map snd block_stats) in - - (* Calculate increase in read & write requests. *) - let read_reqs = - block_stats.D.rd_req -^ prev_block_stats.D.rd_req in - let write_reqs = - block_stats.D.wr_req -^ prev_block_stats.D.wr_req in - let read_bytes = - block_stats.D.rd_bytes -^ prev_block_stats.D.rd_bytes in - let write_bytes = - block_stats.D.wr_bytes -^ prev_block_stats.D.wr_bytes in - - let rd = { rd with - rd_block_rd_reqs = Some read_reqs; - rd_block_wr_reqs = Some write_reqs; - rd_block_rd_bytes = Some read_bytes; - rd_block_wr_bytes = Some write_bytes; - } in - let rd = { rd with - rd_block_rd_info = if !block_in_bytes then - rd.rd_block_rd_bytes else rd.rd_block_rd_reqs; - rd_block_wr_info = if !block_in_bytes then - rd.rd_block_wr_bytes else rd.rd_block_wr_reqs; - } in - name, Active rd - (* For all other domains we can't calculate it, so leave as None. *) - | rd -> rd - ) doms in - - (* Calculate the same as above for network interfaces across - * all network interfaces attached to a domain. - *) - let doms = - List.map ( - function - (* Do we have stats from the previous slice? *) - | name, Active ({ rd_prev_interface_stats = - ((_::_) as prev_interface_stats) } - as rd) -> - let interface_stats = rd.rd_interface_stats in (* stats now *) - - (* Add all the devices together. Throw away device names. *) - let prev_interface_stats = - sum_interface_stats (List.map snd prev_interface_stats) in - let interface_stats = - sum_interface_stats (List.map snd interface_stats) in - - (* Calculate increase in rx & tx bytes. *) - let rx_bytes = - interface_stats.D.rx_bytes -^ prev_interface_stats.D.rx_bytes in - let tx_bytes = - interface_stats.D.tx_bytes -^ prev_interface_stats.D.tx_bytes in - - let rd = { rd with - rd_net_rx_bytes = Some rx_bytes; - rd_net_tx_bytes = Some tx_bytes } in - name, Active rd - (* For all other domains we can't calculate it, so leave as None. *) - | rd -> rd - ) doms in - - (* Collect some extra information in PCPUDisplay display_mode. *) - let pcpu_display = - if !display_mode = PCPUDisplay then ( - (* Get the VCPU info and VCPU->PCPU mappings for active domains. - * Also cull some data we don't care about. - *) - let doms = List.filter_map ( - function - | (name, Active rd) -> - (try - let domid = rd.rd_domid in - let maplen = C.cpumaplen nr_pcpus in - let cpu_stats = D.get_cpu_stats rd.rd_dom in - - (* Note the terminology is confusing. - * - * In libvirt, cpu_time is the total time (hypervisor + vCPU). - * vcpu_time is the time only taken by the vCPU, - * excluding time taken inside the hypervisor. - * - * For each pCPU, libvirt may return either "cpu_time" - * or "vcpu_time" or neither or both. This function - * returns an array pair [|cpu_time, vcpu_time|]; - * if either is missing it is returned as 0. - *) - let find_cpu_usages params = - let rec find_uint64_field name = function - | (n, D.TypedFieldUInt64 usage) :: _ when n = name -> usage - | _ :: params -> find_uint64_field name params - | [] -> 0L - in - [| find_uint64_field "cpu_time" params; - find_uint64_field "vcpu_time" params |] - in - - let pcpu_usages = Array.map find_cpu_usages cpu_stats in - let maxinfo = rd.rd_info.D.nr_virt_cpu in - let nr_vcpus, vcpu_infos, cpumaps = - D.get_vcpus rd.rd_dom maxinfo maplen in - - (* Got previous pcpu_usages for this domain? *) - let prev_pcpu_usages = - try Some (Hashtbl.find last_pcpu_usages domid) - with Not_found -> None in - (* Update last_pcpu_usages. *) - Hashtbl.replace last_pcpu_usages domid pcpu_usages; - - (match prev_pcpu_usages with - | Some prev_pcpu_usages - when Array.length prev_pcpu_usages = Array.length pcpu_usages -> - Some (domid, name, nr_vcpus, vcpu_infos, pcpu_usages, - prev_pcpu_usages, cpumaps, maplen) - | _ -> None (* ignore missing / unequal length prev_vcpu_infos *) - ); - with - Libvirt.Virterror _ -> None(* ignore transient libvirt errs *) - ) - | (_, Inactive) -> None (* ignore inactive doms *) - ) doms in - let nr_doms = List.length doms in - - (* Rearrange the data into a matrix. Major axis (down) is - * pCPUs. Minor axis (right) is domains. At each node we store: - * cpu_time hypervisor + domain (on this pCPU only, nanosecs), - * vcpu_time domain only (on this pCPU only, nanosecs). - *) - let make_3d_array dimx dimy dimz e = - Array.init dimx (fun _ -> Array.make_matrix dimy dimz e) - in - let pcpus = make_3d_array nr_pcpus nr_doms 2 0L in - - List.iteri ( - fun di (domid, name, nr_vcpus, vcpu_infos, pcpu_usages, - prev_pcpu_usages, cpumaps, maplen) -> - (* Which pCPUs can this dom run on? *) - for p = 0 to Array.length pcpu_usages - 1 do - pcpus.(p).(di).(0) <- - pcpu_usages.(p).(0) -^ prev_pcpu_usages.(p).(0); - pcpus.(p).(di).(1) <- - pcpu_usages.(p).(1) -^ prev_pcpu_usages.(p).(1) - done - ) doms; - - (* Sum the total CPU time used by each pCPU, for the %CPU column. *) - let pcpus_cpu_time = Array.map ( - fun row -> - let cpu_time = ref 0L in - for di = 0 to Array.length row-1 do - let t = row.(di).(0) in - cpu_time := !cpu_time +^ t - done; - Int64.to_float !cpu_time - ) pcpus in - - Some (doms, pcpus, pcpus_cpu_time) - ) else - None in - - (* Calculate totals. *) - let totals = List.fold_left ( - fun (count, running, blocked, paused, shutdown, shutoff, - crashed, active, inactive, - total_cpu_time, total_memory, total_domU_memory) -> - function - | (name, Active rd) -> - let test state orig = - if rd.rd_info.D.state = state then orig+1 else orig - in - let running = test D.InfoRunning running in - let blocked = test D.InfoBlocked blocked in - let paused = test D.InfoPaused paused in - let shutdown = test D.InfoShutdown shutdown in - let shutoff = test D.InfoShutoff shutoff in - let crashed = test D.InfoCrashed crashed in - - let total_cpu_time = total_cpu_time +. rd.rd_cpu_time in - let total_memory = total_memory +^ rd.rd_info.D.memory in - let total_domU_memory = total_domU_memory +^ - if rd.rd_domid > 0 then rd.rd_info.D.memory else 0L in - - (count+1, running, blocked, paused, shutdown, shutoff, - crashed, active+1, inactive, - total_cpu_time, total_memory, total_domU_memory) - - | (name, Inactive) -> (* inactive domain *) - (count+1, running, blocked, paused, shutdown, shutoff, - crashed, active, inactive+1, - total_cpu_time, total_memory, total_domU_memory) - ) (0,0,0,0,0,0,0,0,0, 0.,0L,0L) doms in - - (* Update last_time, last_info. *) - last_time := time; - Hashtbl.clear last_info; - List.iter ( - function - | (_, Active rd) -> - let info = rd.rd_info, rd.rd_block_stats, rd.rd_interface_stats in - Hashtbl.add last_info rd.rd_domid info - | _ -> () - ) doms; - - (doms, - time, printable_time, - nr_pcpus, total_cpu, total_cpu_per_pcpu, - totals, - pcpu_display) - in - - collect, clear_pcpu_display_data - -(* Redraw the display. *) -let redraw = - (* Keep a historical list of %CPU usages. *) - let historical_cpu = ref [] in - let historical_cpu_last_time = ref (Unix.gettimeofday ()) in - fun - (_, _, _, _, _, node_info, _, _) (* setup *) - (doms, - time, printable_time, - nr_pcpus, total_cpu, total_cpu_per_pcpu, - totals, - pcpu_display) (* state *) -> - clear (); - - (* Get the screen/window size. *) - let lines, cols = get_size () in - - (* Time. *) - mvaddstr top_lineno 0 (sprintf "virt-top %s - " printable_time); - - (* Basic node_info. *) - addstr - (sprintf "%s %d/%dCPU %dMHz %LdMB " - node_info.C.model node_info.C.cpus nr_pcpus node_info.C.mhz - (node_info.C.memory /^ 1024L)); - (* Save the cursor position for when we come to draw the - * historical CPU times (down in this function). - *) - let stdscr = stdscr () in - let historical_cursor = getyx stdscr in - - (match !display_mode with - | TaskDisplay -> (*---------- Showing domains ----------*) - (* Sort domains on current sort_order. *) - let doms = - let cmp = - match !sort_order with - | DomainName -> - (fun _ -> 0) (* fallthrough to default name compare *) - | Processor -> - (function - | Active rd1, Active rd2 -> - compare rd2.rd_percent_cpu rd1.rd_percent_cpu - | Active _, Inactive -> -1 - | Inactive, Active _ -> 1 - | Inactive, Inactive -> 0) - | Memory -> - (function - | Active { rd_info = info1 }, Active { rd_info = info2 } -> - compare info2.D.memory info1.D.memory - | Active _, Inactive -> -1 - | Inactive, Active _ -> 1 - | Inactive, Inactive -> 0) - | Time -> - (function - | Active { rd_info = info1 }, Active { rd_info = info2 } -> - compare info2.D.cpu_time info1.D.cpu_time - | Active _, Inactive -> -1 - | Inactive, Active _ -> 1 - | Inactive, Inactive -> 0) - | DomainID -> - (function - | Active { rd_domid = id1 }, Active { rd_domid = id2 } -> - compare id1 id2 - | Active _, Inactive -> -1 - | Inactive, Active _ -> 1 - | Inactive, Inactive -> 0) - | NetRX -> - (function - | Active { rd_net_rx_bytes = r1 }, Active { rd_net_rx_bytes = r2 } -> - compare r2 r1 - | Active _, Inactive -> -1 - | Inactive, Active _ -> 1 - | Inactive, Inactive -> 0) - | NetTX -> - (function - | Active { rd_net_tx_bytes = r1 }, Active { rd_net_tx_bytes = r2 } -> - compare r2 r1 - | Active _, Inactive -> -1 - | Inactive, Active _ -> 1 - | Inactive, Inactive -> 0) - | BlockRdRq -> - (function - | Active { rd_block_rd_reqs = r1 }, Active { rd_block_rd_reqs = r2 } -> - compare r2 r1 - | Active _, Inactive -> -1 - | Inactive, Active _ -> 1 - | Inactive, Inactive -> 0) - | BlockWrRq -> - (function - | Active { rd_block_wr_reqs = r1 }, Active { rd_block_wr_reqs = r2 } -> - compare r2 r1 - | Active _, Inactive -> -1 - | Inactive, Active _ -> 1 - | Inactive, Inactive -> 0) - in - let cmp (name1, dom1) (name2, dom2) = - let r = cmp (dom1, dom2) in - if r <> 0 then r - else compare name1 name2 - in - List.sort ~cmp doms in - - (* Print domains. *) - attron A.reverse; - let header_string = if !block_in_bytes - then " ID S RDBY WRBY RXBY TXBY %CPU %MEM TIME NAME" - else " ID S RDRQ WRRQ RXBY TXBY %CPU %MEM TIME NAME" - in - mvaddstr header_lineno 0 - (pad cols header_string); - attroff A.reverse; - - let rec loop lineno = function - | [] -> () - | (name, Active rd) :: doms -> - if lineno < lines then ( - let state = show_state rd.rd_info.D.state in - let rd_req = Show.int64_option rd.rd_block_rd_info in - let wr_req = Show.int64_option rd.rd_block_wr_info in - let rx_bytes = Show.int64_option rd.rd_net_rx_bytes in - let tx_bytes = Show.int64_option rd.rd_net_tx_bytes in - let percent_cpu = Show.percent rd.rd_percent_cpu in - let percent_mem = Int64.to_float rd.rd_mem_percent in - let percent_mem = Show.percent percent_mem in - let time = Show.time rd.rd_info.D.cpu_time in - - let line = sprintf "%5d %c %s %s %s %s %s %s %s %s" - rd.rd_domid state rd_req wr_req rx_bytes tx_bytes - percent_cpu percent_mem time name in - let line = pad cols line in - mvaddstr lineno 0 line; - loop (lineno+1) doms - ) - | (name, Inactive) :: doms -> (* inactive domain *) - if lineno < lines then ( - let line = - sprintf - " - (%s)" - name in - let line = pad cols line in - mvaddstr lineno 0 line; - loop (lineno+1) doms - ) - in - loop domains_lineno doms - - | PCPUDisplay -> (*---------- Showing physical CPUs ----------*) - let doms, pcpus, pcpus_cpu_time = - match pcpu_display with - | Some p -> p - | None -> failwith "internal error: no pcpu_display data" in - - (* Display the pCPUs. *) - let dom_names = - String.concat "" ( - List.map ( - fun (_, name, _, _, _, _, _, _) -> - let len = String.length name in - let width = max (len+1) 12 in - pad width name - ) doms - ) in - attron A.reverse; - mvaddstr header_lineno 0 (pad cols ("PHYCPU %CPU " ^ dom_names)); - attroff A.reverse; - - Array.iteri ( - fun p row -> - mvaddstr (p+domains_lineno) 0 (sprintf "%4d " p); - let cpu_time = pcpus_cpu_time.(p) in (* ns used on this CPU *) - let percent_cpu = 100. *. cpu_time /. total_cpu_per_pcpu in - addstr (Show.percent percent_cpu); - addch ' '; - - List.iteri ( - fun di (domid, name, _, _, _, _, _, _) -> - let t = pcpus.(p).(di).(0) in (* hypervisor + domain *) - let t_only = pcpus.(p).(di).(1) in (* domain only *) - let len = String.length name in - let width = max (len+1) 12 in - let str_t = - if t <= 0L then "" - else ( - let t = Int64.to_float t in - let percent = 100. *. t /. total_cpu_per_pcpu in - Show.percent percent - ) in - let str_t_only = - if t_only <= 0L then "" - else ( - let t_only = Int64.to_float t_only in - let percent = 100. *. t_only /. total_cpu_per_pcpu in - Show.percent percent - ) in - addstr (pad 5 str_t); - addstr (pad 5 str_t_only); - addstr (pad (width-10) " "); - () - ) doms - ) pcpus; - - | NetDisplay -> (*---------- Showing network interfaces ----------*) - (* Only care about active domains. *) - let doms = List.filter_map ( - function - | (name, Active rd) -> Some (name, rd) - | (_, Inactive) -> None - ) doms in - - (* For each domain we have a list of network interfaces seen - * this slice, and seen in the previous slice, which we now - * match up to get a list of (domain, interface) for which - * we have current & previous knowledge. (And ignore the rest). - *) - let devs = - List.map ( - fun (name, rd) -> - List.filter_map ( - fun (dev, stats) -> - try - (* Have prev slice stats for this device? *) - let prev_stats = - List.assoc dev rd.rd_prev_interface_stats in - Some (dev, name, rd, stats, prev_stats) - with Not_found -> None - ) rd.rd_interface_stats - ) doms in - - (* Finally we have a list of: - * device name, domain name, rd_* stuff, curr stats, prev stats. - *) - let devs : (string * string * rd_active * - D.interface_stats * D.interface_stats) list = - List.flatten devs in - - (* Difference curr slice & prev slice. *) - let devs = List.map ( - fun (dev, name, rd, curr, prev) -> - dev, name, rd, diff_interface_stats curr prev - ) devs in - - (* Sort by current sort order, but map some of the standard - * sort orders into ones which makes sense here. - *) - let devs = - let cmp = - match !sort_order with - | DomainName -> - (fun _ -> 0) (* fallthrough to default name compare *) - | DomainID -> - (fun (_, { rd_domid = id1 }, _, { rd_domid = id2 }) -> - compare id1 id2) - | Processor | Memory | Time | BlockRdRq | BlockWrRq - (* fallthrough to RXBY comparison. *) - | NetRX -> - (fun ({ D.rx_bytes = b1 }, _, { D.rx_bytes = b2 }, _) -> - compare b2 b1) - | NetTX -> - (fun ({ D.tx_bytes = b1 }, _, { D.tx_bytes = b2 }, _) -> - compare b2 b1) - in - let cmp (dev1, name1, rd1, stats1) (dev2, name2, rd2, stats2) = - let r = cmp (stats1, rd1, stats2, rd2) in - if r <> 0 then r - else compare (dev1, name1) (dev2, name2) - in - List.sort ~cmp devs in - - (* Print the header for network devices. *) - attron A.reverse; - mvaddstr header_lineno 0 - (pad cols " ID S RXBY TXBY RXPK TXPK DOMAIN INTERFACE"); - attroff A.reverse; - - (* Print domains and devices. *) - let rec loop lineno = function - | [] -> () - | (dev, name, rd, stats) :: devs -> - if lineno < lines then ( - let state = show_state rd.rd_info.D.state in - let rx_bytes = - if stats.D.rx_bytes >= 0L - then Show.int64 stats.D.rx_bytes - else " " in - let tx_bytes = - if stats.D.tx_bytes >= 0L - then Show.int64 stats.D.tx_bytes - else " " in - let rx_packets = - if stats.D.rx_packets >= 0L - then Show.int64 stats.D.rx_packets - else " " in - let tx_packets = - if stats.D.tx_packets >= 0L - then Show.int64 stats.D.tx_packets - else " " in - - let line = sprintf "%5d %c %s %s %s %s %-12s %s" - rd.rd_domid state - rx_bytes tx_bytes - rx_packets tx_packets - (pad 12 name) dev in - let line = pad cols line in - mvaddstr lineno 0 line; - loop (lineno+1) devs - ) - in - loop domains_lineno devs - - | BlockDisplay -> (*---------- Showing block devices ----------*) - (* Only care about active domains. *) - let doms = List.filter_map ( - function - | (name, Active rd) -> Some (name, rd) - | (_, Inactive) -> None - ) doms in - - (* For each domain we have a list of block devices seen - * this slice, and seen in the previous slice, which we now - * match up to get a list of (domain, device) for which - * we have current & previous knowledge. (And ignore the rest). - *) - let devs = - List.map ( - fun (name, rd) -> - List.filter_map ( - fun (dev, stats) -> - try - (* Have prev slice stats for this device? *) - let prev_stats = - List.assoc dev rd.rd_prev_block_stats in - Some (dev, name, rd, stats, prev_stats) - with Not_found -> None - ) rd.rd_block_stats - ) doms in - - (* Finally we have a list of: - * device name, domain name, rd_* stuff, curr stats, prev stats. - *) - let devs : (string * string * rd_active * - D.block_stats * D.block_stats) list = - List.flatten devs in - - (* Difference curr slice & prev slice. *) - let devs = List.map ( - fun (dev, name, rd, curr, prev) -> - dev, name, rd, diff_block_stats curr prev - ) devs in - - (* Sort by current sort order, but map some of the standard - * sort orders into ones which makes sense here. - *) - let devs = - let cmp = - match !sort_order with - | DomainName -> - (fun _ -> 0) (* fallthrough to default name compare *) - | DomainID -> - (fun (_, { rd_domid = id1 }, _, { rd_domid = id2 }) -> - compare id1 id2) - | Processor | Memory | Time | NetRX | NetTX - (* fallthrough to RDRQ comparison. *) - | BlockRdRq -> - (fun ({ D.rd_req = b1 }, _, { D.rd_req = b2 }, _) -> - compare b2 b1) - | BlockWrRq -> - (fun ({ D.wr_req = b1 }, _, { D.wr_req = b2 }, _) -> - compare b2 b1) - in - let cmp (dev1, name1, rd1, stats1) (dev2, name2, rd2, stats2) = - let r = cmp (stats1, rd1, stats2, rd2) in - if r <> 0 then r - else compare (dev1, name1) (dev2, name2) - in - List.sort ~cmp devs in - - (* Print the header for block devices. *) - attron A.reverse; - mvaddstr header_lineno 0 - (pad cols " ID S RDBY WRBY RDRQ WRRQ DOMAIN DEVICE"); - attroff A.reverse; - - (* Print domains and devices. *) - let rec loop lineno = function - | [] -> () - | (dev, name, rd, stats) :: devs -> - if lineno < lines then ( - let state = show_state rd.rd_info.D.state in - let rd_bytes = - if stats.D.rd_bytes >= 0L - then Show.int64 stats.D.rd_bytes - else " " in - let wr_bytes = - if stats.D.wr_bytes >= 0L - then Show.int64 stats.D.wr_bytes - else " " in - let rd_req = - if stats.D.rd_req >= 0L - then Show.int64 stats.D.rd_req - else " " in - let wr_req = - if stats.D.wr_req >= 0L - then Show.int64 stats.D.wr_req - else " " in - - let line = sprintf "%5d %c %s %s %s %s %-12s %s" - rd.rd_domid state - rd_bytes wr_bytes - rd_req wr_req - (pad 12 name) dev in - let line = pad cols line in - mvaddstr lineno 0 line; - loop (lineno+1) devs - ) - in - loop domains_lineno devs - ); (* end of display_mode conditional section *) - - let (count, running, blocked, paused, shutdown, shutoff, - crashed, active, inactive, - total_cpu_time, total_memory, total_domU_memory) = totals in - - mvaddstr summary_lineno 0 - (sprintf - (f_"%d domains, %d active, %d running, %d sleeping, %d paused, %d inactive D:%d O:%d X:%d") - count active running blocked paused inactive shutdown shutoff crashed); - - (* Total %CPU used, and memory summary. *) - let percent_cpu = 100. *. total_cpu_time /. total_cpu in - mvaddstr (summary_lineno+1) 0 - (sprintf - (f_"CPU: %2.1f%% Mem: %Ld MB (%Ld MB by guests)") - percent_cpu (total_memory /^ 1024L) (total_domU_memory /^ 1024L)); - - (* Time to grab another historical %CPU for the list? *) - if time >= !historical_cpu_last_time +. float !historical_cpu_delay - then ( - historical_cpu := percent_cpu :: List.take 10 !historical_cpu; - historical_cpu_last_time := time - ); - - (* Display historical CPU time. *) - let () = - let y, x = historical_cursor in - let maxwidth = cols - x in - let line = - String.concat " " - (List.map (sprintf "%2.1f%%") !historical_cpu) in - let line = pad maxwidth line in - mvaddstr y x line; - () in - - move message_lineno 0; (* Park cursor in message area, as with top. *) - refresh () (* Refresh the display. *) - -(* Write CSV header row. *) -let write_csv_header () = - (!csv_write) ( - [ "Hostname"; "Time"; "Arch"; "Physical CPUs"; - "Count"; "Running"; "Blocked"; "Paused"; "Shutdown"; - "Shutoff"; "Crashed"; "Active"; "Inactive"; - "%CPU"; - "Total hardware memory (KB)"; - "Total memory (KB)"; "Total guest memory (KB)"; - "Total CPU time (ns)" ] @ - (* These fields are repeated for each domain: *) - [ "Domain ID"; "Domain name"; ] @ - (if !csv_cpu then [ "CPU (ns)"; "%CPU"; ] else []) @ - (if !csv_mem then [ "Mem (bytes)"; "%Mem";] else []) @ - (if !csv_block && not !block_in_bytes - then [ "Block RDRQ"; "Block WRRQ"; ] else []) @ - (if !csv_block && !block_in_bytes - then [ "Block RDBY"; "Block WRBY"; ] else []) @ - (if !csv_net then [ "Net RXBY"; "Net TXBY" ] else []) - ) - -(* Write summary data to CSV file. *) -let append_csv - (_, _, _, _, _, node_info, hostname, _) (* setup *) - (doms, - _, printable_time, - nr_pcpus, total_cpu, _, - totals, - _) (* state *) = - - (* The totals / summary fields. *) - let (count, running, blocked, paused, shutdown, shutoff, - crashed, active, inactive, - total_cpu_time, total_memory, total_domU_memory) = totals in - - let percent_cpu = 100. *. total_cpu_time /. total_cpu in - - let summary_fields = [ - hostname; printable_time; node_info.C.model; string_of_int nr_pcpus; - string_of_int count; string_of_int running; string_of_int blocked; - string_of_int paused; string_of_int shutdown; string_of_int shutoff; - string_of_int crashed; string_of_int active; string_of_int inactive; - sprintf "%2.1f" percent_cpu; - Int64.to_string node_info.C.memory; - Int64.to_string total_memory; Int64.to_string total_domU_memory; - Int64.to_string (Int64.of_float total_cpu_time) - ] in - - (* The domains. - * - * Sort them by ID so that the list of relatively stable. Ignore - * inactive domains. - *) - let doms = List.filter_map ( - function - | _, Inactive -> None (* Ignore inactive domains. *) - | name, Active rd -> Some (name, rd) - ) doms in - let cmp (_, { rd_domid = rd_domid1 }) (_, { rd_domid = rd_domid2 }) = - compare rd_domid1 rd_domid2 - in - let doms = List.sort ~cmp doms in - - let string_of_int64_option = Option.map_default Int64.to_string "" in - - let domain_fields = List.map ( - fun (domname, rd) -> - [ string_of_int rd.rd_domid; domname ] @ - (if !csv_cpu then [ - string_of_float rd.rd_cpu_time; string_of_float rd.rd_percent_cpu - ] else []) @ - (if !csv_mem then [ - Int64.to_string rd.rd_mem_bytes; Int64.to_string rd.rd_mem_percent - ] else []) @ - (if !csv_block then [ - string_of_int64_option rd.rd_block_rd_info; - string_of_int64_option rd.rd_block_wr_info; - ] else []) @ - (if !csv_net then [ - string_of_int64_option rd.rd_net_rx_bytes; - string_of_int64_option rd.rd_net_tx_bytes; - ] else []) - ) doms in - let domain_fields = List.flatten domain_fields in - - (!csv_write) (summary_fields @ domain_fields) - -let dump_stdout - (_, _, _, _, _, node_info, hostname, _) (* setup *) - (doms, - _, printable_time, - nr_pcpus, total_cpu, _, - totals, - _) (* state *) = - - (* Header for this iteration *) - printf "virt-top time %s Host %s %s %d/%dCPU %dMHz %LdMB \n" - printable_time hostname node_info.C.model node_info.C.cpus nr_pcpus - node_info.C.mhz (node_info.C.memory /^ 1024L); - (* dump domain information one by one *) - let rd, wr = if !block_in_bytes then "RDBY", "WRBY" else "RDRQ", "WRRQ" - in - printf " ID S %s %s RXBY TXBY %%CPU %%MEM TIME NAME\n" rd wr; - - (* sort by ID *) - let doms = - let compare = - (function - | Active {rd_domid = id1 }, Active {rd_domid = id2} -> - compare id1 id2 - | Active _, Inactive -> -1 - | Inactive, Active _ -> 1 - | Inactive, Inactive -> 0) - in - let cmp (name1, dom1) (name2, dom2) = compare(dom1, dom2) in - List.sort ~cmp doms in - (*Print domains *) - let dump_domain = fun name rd - -> begin - let state = show_state rd.rd_info.D.state in - let rd_req = if rd.rd_block_rd_info = None then " 0" - else Show.int64_option rd.rd_block_rd_info in - let wr_req = if rd.rd_block_wr_info = None then " 0" - else Show.int64_option rd.rd_block_wr_info in - let rx_bytes = if rd.rd_net_rx_bytes = None then " 0" - else Show.int64_option rd.rd_net_rx_bytes in - let tx_bytes = if rd.rd_net_tx_bytes = None then " 0" - else Show.int64_option rd.rd_net_tx_bytes in - let percent_cpu = Show.percent rd.rd_percent_cpu in - let percent_mem = Int64.to_float rd.rd_mem_percent in - let percent_mem = Show.percent percent_mem in - let time = Show.time rd.rd_info.D.cpu_time in - printf "%5d %c %s %s %s %s %s %s %s %s\n" - rd.rd_domid state rd_req wr_req rx_bytes tx_bytes - percent_cpu percent_mem time name; - end - in - List.iter ( - function - | name, Active dom -> dump_domain name dom - | name, Inactive -> () - ) doms; - flush stdout - (* Main loop. *) let rec main_loop ((_, batch_mode, script_mode, csv_enabled, stream_mode, _, _, _) as setup) = - if csv_enabled then write_csv_header (); + let csv_flags = !csv_cpu, !csv_mem, !csv_block, !csv_net in + + if csv_enabled then + Csv_output.write_csv_header csv_flags !block_in_bytes; while not !quit do - let state = collect setup in (* Collect stats. *) + (* Collect stats. *) + let state = collect setup !block_in_bytes in + let pcpu_display = + if !display_mode = PCPUDisplay then Some (collect_pcpu state) + else None in (* Redraw display. *) - if not script_mode && not stream_mode then redraw setup state; - if csv_enabled then append_csv setup state; (* Update CSV file. *) - if stream_mode then dump_stdout setup state; (* dump to stdout *) + if not script_mode && not stream_mode then + Redraw.redraw !display_mode !sort_order + setup !block_in_bytes !historical_cpu_delay + state pcpu_display; + + (* Update CSV file. *) + if csv_enabled then + Csv_output.append_csv setup csv_flags state; + + (* Append to stream output file. *) + if stream_mode then + Stream_output.append_stream setup !block_in_bytes state; (* Clear up unused virDomainPtr objects. *) Gc.compact (); @@ -1440,11 +356,10 @@ let rec main_loop ((_, batch_mode, script_mode, csv_enabled, stream_mode, _, _, (* No --end-time option, so use the current delay. *) !delay | Some end_time -> - let (_, time, _, _, _, _, _, _) = state in let delay_secs = float !delay /. 1000. in - if end_time <= time +. delay_secs then ( + if end_time <= state.rd_time +. delay_secs then ( quit := true; - let delay = int_of_float (1000. *. (end_time -. time)) in + let delay = int_of_float (1000. *. (end_time -. state.rd_time)) in if delay >= 0 then delay else 0 ) else !delay in diff --git a/src/top.mli b/src/top.mli index b0953dd..b625910 100644 --- a/src/top.mli +++ b/src/top.mli @@ -1,5 +1,5 @@ (* 'top'-like tool for libvirt domains. - (C) Copyright 2007-2009 Richard W.M. Jones, Red Hat Inc. + (C) Copyright 2007-2017 Richard W.M. Jones, Red Hat Inc. http://libvirt.org/ This program is free software; you can redistribute it and/or modify @@ -17,23 +17,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) -(* Hook for [Opt_xml] to override (if present). *) -val parse_device_xml : - (int -> [ `R ] Libvirt.Domain.t -> string list * string list) ref - -(* Hooks for [Opt_csv] to override (if present). *) +(* Hook for [Opt_csv] to override (if present). *) val csv_start : (string -> unit) ref -val csv_write : (string list -> unit) ref (* Hook for [Opt_calendar] to override (if present). *) val parse_date_time : (string -> float) ref -type setup = - Libvirt.ro Libvirt.Connect.t (* connection *) - * bool * bool * bool * bool (* batch, script, csv, stream mode *) - * Libvirt.Connect.node_info (* node_info *) - * string (* hostname *) - * (int * int * int) (* libvirt version *) - -val start_up : unit -> setup -val main_loop : setup -> unit +val start_up : unit -> Types.setup +val main_loop : Types.setup -> unit diff --git a/src/types.ml b/src/types.ml new file mode 100644 index 0000000..2fdd49b --- /dev/null +++ b/src/types.ml @@ -0,0 +1,147 @@ +(* 'top'-like tool for libvirt domains. + (C) Copyright 2007-2017 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 Opt_gettext.Gettext +open Utils + +module C = Libvirt.Connect +module D = Libvirt.Domain + +(* XXX We should get rid of this type. *) +type setup = + Libvirt.ro C.t (* connection *) + * bool * bool * bool * bool (* batch, script, csv, stream mode *) + * C.node_info (* node_info *) + * string (* hostname *) + * (int * int * int) (* libvirt version *) + +(* Sort order. *) +type sort_order = + | DomainID | DomainName | Processor | Memory | Time + | NetRX | NetTX | BlockRdRq | BlockWrRq +let all_sort_fields = [ + DomainID; DomainName; Processor; Memory; Time; + NetRX; NetTX; BlockRdRq; BlockWrRq +] +let printable_sort_order = function + | Processor -> s_"%CPU" + | Memory -> s_"%MEM" + | Time -> s_"TIME (CPU time)" + | DomainID -> s_"Domain ID" + | DomainName -> s_"Domain name" + | NetRX -> s_"Net RX bytes" + | NetTX -> s_"Net TX bytes" + | BlockRdRq -> s_"Block read reqs" + | BlockWrRq -> s_"Block write reqs" +let sort_order_of_cli = function + | "cpu" | "processor" -> Processor + | "mem" | "memory" -> Memory + | "time" -> Time + | "id" -> DomainID + | "name" -> DomainName + | "netrx" -> NetRX | "nettx" -> NetTX + | "blockrdrq" -> BlockRdRq | "blockwrrq" -> BlockWrRq + | str -> + failwithf (f_"%s: sort order should be: %s") + str "cpu|mem|time|id|name|netrx|nettx|blockrdrq|blockwrrq" +let cli_of_sort_order = function + | Processor -> "cpu" + | Memory -> "mem" + | Time -> "time" + | DomainID -> "id" + | DomainName -> "name" + | NetRX -> "netrx" + | NetTX -> "nettx" + | BlockRdRq -> "blockrdrq" + | BlockWrRq -> "blockwrrq" + +(* Current major display mode: TaskDisplay is the normal display. *) +type display = TaskDisplay | PCPUDisplay | BlockDisplay | NetDisplay + +let display_of_cli = function + | "task" -> TaskDisplay + | "pcpu" -> PCPUDisplay + | "block" -> BlockDisplay + | "net" -> NetDisplay + | str -> + failwithf (f_"%s: display should be %s") str "task|pcpu|block|net" +let cli_of_display = function + | TaskDisplay -> "task" + | PCPUDisplay -> "pcpu" + | BlockDisplay -> "block" + | NetDisplay -> "net" + +(* Sum Domain.block_stats structures together. Missing fields + * get forced to 0. Empty list returns all 0. + *) +let zero_block_stats = + { D.rd_req = 0L; rd_bytes = 0L; wr_req = 0L; wr_bytes = 0L; errs = 0L } +let add_block_stats bs1 bs2 = + let add f1 f2 = if f1 >= 0L && f2 >= 0L then f1 +^ f2 else 0L in + { D.rd_req = add bs1.D.rd_req bs2.D.rd_req; + rd_bytes = add bs1.D.rd_bytes bs2.D.rd_bytes; + wr_req = add bs1.D.wr_req bs2.D.wr_req; + wr_bytes = add bs1.D.wr_bytes bs2.D.wr_bytes; + errs = add bs1.D.errs bs2.D.errs } +let sum_block_stats = + List.fold_left add_block_stats zero_block_stats + +(* Get the difference between two block_stats structures. Missing data + * forces the difference to -1. + *) +let diff_block_stats curr prev = + let sub f1 f2 = if f1 >= 0L && f2 >= 0L then f1 -^ f2 else -1L in + { D.rd_req = sub curr.D.rd_req prev.D.rd_req; + rd_bytes = sub curr.D.rd_bytes prev.D.rd_bytes; + wr_req = sub curr.D.wr_req prev.D.wr_req; + wr_bytes = sub curr.D.wr_bytes prev.D.wr_bytes; + errs = sub curr.D.errs prev.D.errs } + +(* Sum Domain.interface_stats structures together. Missing fields + * get forced to 0. Empty list returns all 0. + *) +let zero_interface_stats = + { D.rx_bytes = 0L; rx_packets = 0L; rx_errs = 0L; rx_drop = 0L; + tx_bytes = 0L; tx_packets = 0L; tx_errs = 0L; tx_drop = 0L } +let add_interface_stats is1 is2 = + let add f1 f2 = if f1 >= 0L && f2 >= 0L then f1 +^ f2 else 0L in + { D.rx_bytes = add is1.D.rx_bytes is2.D.rx_bytes; + rx_packets = add is1.D.rx_packets is2.D.rx_packets; + rx_errs = add is1.D.rx_errs is2.D.rx_errs; + rx_drop = add is1.D.rx_drop is2.D.rx_drop; + tx_bytes = add is1.D.tx_bytes is2.D.tx_bytes; + tx_packets = add is1.D.tx_packets is2.D.tx_packets; + tx_errs = add is1.D.tx_errs is2.D.tx_errs; + tx_drop = add is1.D.tx_drop is2.D.tx_drop } +let sum_interface_stats = + List.fold_left add_interface_stats zero_interface_stats + +(* Get the difference between two interface_stats structures. + * Missing data forces the difference to -1. + *) +let diff_interface_stats curr prev = + let sub f1 f2 = if f1 >= 0L && f2 >= 0L then f1 -^ f2 else -1L in + { D.rx_bytes = sub curr.D.rx_bytes prev.D.rx_bytes; + rx_packets = sub curr.D.rx_packets prev.D.rx_packets; + rx_errs = sub curr.D.rx_errs prev.D.rx_errs; + rx_drop = sub curr.D.rx_drop prev.D.rx_drop; + tx_bytes = sub curr.D.tx_bytes prev.D.tx_bytes; + tx_packets = sub curr.D.tx_packets prev.D.tx_packets; + tx_errs = sub curr.D.tx_errs prev.D.tx_errs; + tx_drop = sub curr.D.tx_drop prev.D.tx_drop } diff --git a/src/types.mli b/src/types.mli new file mode 100644 index 0000000..6297482 --- /dev/null +++ b/src/types.mli @@ -0,0 +1,49 @@ +(* 'top'-like tool for libvirt domains. + (C) Copyright 2007-2017 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. +*) + +(* XXX We should get rid of this type. *) +type setup = + Libvirt.ro Libvirt.Connect.t (* connection *) + * bool * bool * bool * bool (* batch, script, csv, stream mode *) + * Libvirt.Connect.node_info (* node_info *) + * string (* hostname *) + * (int * int * int) (* libvirt version *) + +(* Sort order. *) +type sort_order = + | DomainID | DomainName | Processor | Memory | Time + | NetRX | NetTX | BlockRdRq | BlockWrRq + +val all_sort_fields : sort_order list +val printable_sort_order : sort_order -> string +val sort_order_of_cli : string -> sort_order +val cli_of_sort_order : sort_order -> string + +(* Current major display mode: TaskDisplay is the normal display. *) +type display = TaskDisplay | PCPUDisplay | BlockDisplay | NetDisplay + +val display_of_cli : string -> display +val cli_of_display : display -> string + +(* Helpers for manipulating block_stats & interface_stats. *) +val sum_block_stats : Libvirt.Domain.block_stats list -> Libvirt.Domain.block_stats +val diff_block_stats : Libvirt.Domain.block_stats -> Libvirt.Domain.block_stats -> Libvirt.Domain.block_stats + +val sum_interface_stats : Libvirt.Domain.interface_stats list -> Libvirt.Domain.interface_stats +val diff_interface_stats : Libvirt.Domain.interface_stats -> Libvirt.Domain.interface_stats -> Libvirt.Domain.interface_stats diff --git a/src/utils.ml b/src/utils.ml index 3dc637d..5fcc905 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -21,12 +21,6 @@ open Printf -open Opt_gettext.Gettext - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - let (//) = Filename.concat (* Int64 operators for convenience. *) @@ -166,62 +160,3 @@ module Show = struct sprintf "%3Ldd%02Ld:%02Ld" days hours mins ) end - -(* Sum Domain.block_stats structures together. Missing fields - * get forced to 0. Empty list returns all 0. - *) -let zero_block_stats = - { D.rd_req = 0L; rd_bytes = 0L; wr_req = 0L; wr_bytes = 0L; errs = 0L } -let add_block_stats bs1 bs2 = - let add f1 f2 = if f1 >= 0L && f2 >= 0L then f1 +^ f2 else 0L in - { D.rd_req = add bs1.D.rd_req bs2.D.rd_req; - rd_bytes = add bs1.D.rd_bytes bs2.D.rd_bytes; - wr_req = add bs1.D.wr_req bs2.D.wr_req; - wr_bytes = add bs1.D.wr_bytes bs2.D.wr_bytes; - errs = add bs1.D.errs bs2.D.errs } -let sum_block_stats = - List.fold_left add_block_stats zero_block_stats - -(* Get the difference between two block_stats structures. Missing data - * forces the difference to -1. - *) -let diff_block_stats curr prev = - let sub f1 f2 = if f1 >= 0L && f2 >= 0L then f1 -^ f2 else -1L in - { D.rd_req = sub curr.D.rd_req prev.D.rd_req; - rd_bytes = sub curr.D.rd_bytes prev.D.rd_bytes; - wr_req = sub curr.D.wr_req prev.D.wr_req; - wr_bytes = sub curr.D.wr_bytes prev.D.wr_bytes; - errs = sub curr.D.errs prev.D.errs } - -(* Sum Domain.interface_stats structures together. Missing fields - * get forced to 0. Empty list returns all 0. - *) -let zero_interface_stats = - { D.rx_bytes = 0L; rx_packets = 0L; rx_errs = 0L; rx_drop = 0L; - tx_bytes = 0L; tx_packets = 0L; tx_errs = 0L; tx_drop = 0L } -let add_interface_stats is1 is2 = - let add f1 f2 = if f1 >= 0L && f2 >= 0L then f1 +^ f2 else 0L in - { D.rx_bytes = add is1.D.rx_bytes is2.D.rx_bytes; - rx_packets = add is1.D.rx_packets is2.D.rx_packets; - rx_errs = add is1.D.rx_errs is2.D.rx_errs; - rx_drop = add is1.D.rx_drop is2.D.rx_drop; - tx_bytes = add is1.D.tx_bytes is2.D.tx_bytes; - tx_packets = add is1.D.tx_packets is2.D.tx_packets; - tx_errs = add is1.D.tx_errs is2.D.tx_errs; - tx_drop = add is1.D.tx_drop is2.D.tx_drop } -let sum_interface_stats = - List.fold_left add_interface_stats zero_interface_stats - -(* Get the difference between two interface_stats structures. - * Missing data forces the difference to -1. - *) -let diff_interface_stats curr prev = - let sub f1 f2 = if f1 >= 0L && f2 >= 0L then f1 -^ f2 else -1L in - { D.rx_bytes = sub curr.D.rx_bytes prev.D.rx_bytes; - rx_packets = sub curr.D.rx_packets prev.D.rx_packets; - rx_errs = sub curr.D.rx_errs prev.D.rx_errs; - rx_drop = sub curr.D.rx_drop prev.D.rx_drop; - tx_bytes = sub curr.D.tx_bytes prev.D.tx_bytes; - tx_packets = sub curr.D.tx_packets prev.D.tx_packets; - tx_errs = sub curr.D.tx_errs prev.D.tx_errs; - tx_drop = sub curr.D.tx_drop prev.D.tx_drop } diff --git a/src/utils.mli b/src/utils.mli index 5b71b31..6e81215 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -46,12 +46,3 @@ module Show : sig val int64 : int64 -> string val time : int64 -> string end - -(* Helpers for manipulating block_stats & interface_stats. *) -open Libvirt.Domain - -val sum_block_stats : block_stats list -> block_stats -val diff_block_stats : block_stats -> block_stats -> block_stats - -val sum_interface_stats : interface_stats list -> interface_stats -val diff_interface_stats : interface_stats -> interface_stats -> interface_stats -- 2.13.1