src/types.ml

   1 (* 'top'-like tool for libvirt domains.
   2    (C) Copyright 2007-2017 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   5    This program is free software; you can redistribute it and/or modify
   6    it under the terms of the GNU General Public License as published by
   7    the Free Software Foundation; either version 2 of the License, or
   8    (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18 *)
  19
  20 open Opt_gettext.Gettext
  21 open Utils
  22
  23 module C = Libvirt.Connect
  24 module D = Libvirt.Domain
  25
  26 (* XXX We should get rid of this type. *)
  27 type setup =
  28     Libvirt.ro C.t              (* connection *)
  29     * bool * bool * bool * bool (* batch, script, csv, stream mode *)
  30     * C.node_info               (* node_info *)
  31     * string                    (* hostname *)
  32     * (int * int * int)         (* libvirt version *)
  33
  34 (* Sort order. *)
  35 type sort_order =
  36   | DomainID | DomainName | Processor | Memory | Time
  37   | NetRX | NetTX | BlockRdRq | BlockWrRq
  38 let all_sort_fields = [
  39   DomainID; DomainName; Processor; Memory; Time;
  40   NetRX; NetTX; BlockRdRq; BlockWrRq
  41 ]
  42 let printable_sort_order = function
  43   | Processor -> s_"%CPU"
  44   | Memory -> s_"%MEM"
  45   | Time -> s_"TIME (CPU time)"
  46   | DomainID -> s_"Domain ID"
  47   | DomainName -> s_"Domain name"
  48   | NetRX -> s_"Net RX bytes"
  49   | NetTX -> s_"Net TX bytes"
  50   | BlockRdRq -> s_"Block read reqs"
  51   | BlockWrRq -> s_"Block write reqs"
  52 let sort_order_of_cli = function
  53   | "cpu" | "processor" -> Processor
  54   | "mem" | "memory" -> Memory
  55   | "time" -> Time
  56   | "id" -> DomainID
  57   | "name" -> DomainName
  58   | "netrx" -> NetRX | "nettx" -> NetTX
  59   | "blockrdrq" -> BlockRdRq | "blockwrrq" -> BlockWrRq
  60   | str ->
  61       failwithf (f_"%s: sort order should be: %s")
  62         str "cpu|mem|time|id|name|netrx|nettx|blockrdrq|blockwrrq"
  63 let cli_of_sort_order = function
  64   | Processor -> "cpu"
  65   | Memory -> "mem"
  66   | Time -> "time"
  67   | DomainID -> "id"
  68   | DomainName -> "name"
  69   | NetRX -> "netrx"
  70   | NetTX -> "nettx"
  71   | BlockRdRq -> "blockrdrq"
  72   | BlockWrRq -> "blockwrrq"
  73
  74 (* Current major display mode: TaskDisplay is the normal display. *)
  75 type display = TaskDisplay | PCPUDisplay | BlockDisplay | NetDisplay
  76
  77 let display_of_cli = function
  78   | "task" -> TaskDisplay
  79   | "pcpu" -> PCPUDisplay
  80   | "block" -> BlockDisplay
  81   | "net" -> NetDisplay
  82   | str ->
  83       failwithf (f_"%s: display should be %s") str "task|pcpu|block|net"
  84 let cli_of_display = function
  85   | TaskDisplay -> "task"
  86   | PCPUDisplay -> "pcpu"
  87   | BlockDisplay -> "block"
  88   | NetDisplay -> "net"
  89
  90 (* Sum Domain.block_stats structures together.  Missing fields
  91  * get forced to 0.  Empty list returns all 0.
  92  *)
  93 let zero_block_stats =
  94   { D.rd_req = 0L; rd_bytes = 0L; wr_req = 0L; wr_bytes = 0L; errs = 0L }
  95 let add_block_stats bs1 bs2 =
  96   let add f1 f2 = if f1 >= 0L && f2 >= 0L then f1 +^ f2 else 0L in
  97   { D.rd_req = add bs1.D.rd_req   bs2.D.rd_req;
  98     rd_bytes = add bs1.D.rd_bytes bs2.D.rd_bytes;
  99     wr_req   = add bs1.D.wr_req   bs2.D.wr_req;
 100     wr_bytes = add bs1.D.wr_bytes bs2.D.wr_bytes;
 101     errs     = add bs1.D.errs     bs2.D.errs }
 102 let sum_block_stats =
 103   List.fold_left add_block_stats zero_block_stats
 104
 105 (* Get the difference between two block_stats structures.  Missing data
 106  * forces the difference to -1.
 107  *)
 108 let diff_block_stats curr prev =
 109   let sub f1 f2 = if f1 >= 0L && f2 >= 0L then f1 -^ f2 else -1L in
 110   { D.rd_req = sub curr.D.rd_req   prev.D.rd_req;
 111     rd_bytes = sub curr.D.rd_bytes prev.D.rd_bytes;
 112     wr_req   = sub curr.D.wr_req   prev.D.wr_req;
 113     wr_bytes = sub curr.D.wr_bytes prev.D.wr_bytes;
 114     errs     = sub curr.D.errs     prev.D.errs }
 115
 116 (* Sum Domain.interface_stats structures together.  Missing fields
 117  * get forced to 0.  Empty list returns all 0.
 118  *)
 119 let zero_interface_stats =
 120   { D.rx_bytes = 0L; rx_packets = 0L; rx_errs = 0L; rx_drop = 0L;
 121     tx_bytes = 0L; tx_packets = 0L; tx_errs = 0L; tx_drop = 0L }
 122 let add_interface_stats is1 is2 =
 123   let add f1 f2 = if f1 >= 0L && f2 >= 0L then f1 +^ f2 else 0L in
 124   { D.rx_bytes = add is1.D.rx_bytes   is2.D.rx_bytes;
 125     rx_packets = add is1.D.rx_packets is2.D.rx_packets;
 126     rx_errs    = add is1.D.rx_errs    is2.D.rx_errs;
 127     rx_drop    = add is1.D.rx_drop    is2.D.rx_drop;
 128     tx_bytes   = add is1.D.tx_bytes   is2.D.tx_bytes;
 129     tx_packets = add is1.D.tx_packets is2.D.tx_packets;
 130     tx_errs    = add is1.D.tx_errs    is2.D.tx_errs;
 131     tx_drop    = add is1.D.tx_drop    is2.D.tx_drop }
 132 let sum_interface_stats =
 133   List.fold_left add_interface_stats zero_interface_stats
 134
 135 (* Get the difference between two interface_stats structures.
 136  * Missing data forces the difference to -1.
 137  *)
 138 let diff_interface_stats curr prev =
 139   let sub f1 f2 = if f1 >= 0L && f2 >= 0L then f1 -^ f2 else -1L in
 140   { D.rx_bytes = sub curr.D.rx_bytes   prev.D.rx_bytes;
 141     rx_packets = sub curr.D.rx_packets prev.D.rx_packets;
 142     rx_errs    = sub curr.D.rx_errs    prev.D.rx_errs;
 143     rx_drop    = sub curr.D.rx_drop    prev.D.rx_drop;
 144     tx_bytes   = sub curr.D.tx_bytes   prev.D.tx_bytes;
 145     tx_packets = sub curr.D.tx_packets prev.D.tx_packets;
 146     tx_errs    = sub curr.D.tx_errs    prev.D.tx_errs;
 147     tx_drop    = sub curr.D.tx_drop    prev.D.tx_drop }