dmon.pl

   1 #!/usr/bin/env perl
   2 # dmon -- DTrace-backed IP network real-time monitoring utility
   3 # Copyright (C) 2022-2025 Sergey Matveev <stargrave@stargrave.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, version 3 of the License.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16 =pod
  17
  18 =head1 DESCRIPTION
  19
  20 dmon is DTrace-backed IP network real-time monitoring utility. It can be
  21 treated as a replacement for iftop utility, that does not always work
  22 properly with IPv6.
  23
  24 It generates DTrace script to gather data about send and received IP
  25 packets, or about TCP, UDP, UDP-Lite, SCTP ones. It collects and
  26 aggregates necessary data and sends it back to that Perl program, that
  27 prettifies its output.
  28
  29 =head1 USAGE
  30
  31 There are two modes of operation:
  32
  33 =over
  34
  35 =item IP packets monitoring
  36
  37 You have to specify exact network interface names you wish to take into
  38 account. Pay attention that all packets are captured, even forwarded
  39 ones, that is useful on router.
  40
  41 =item TCP/UDP/UDP-Lite/SCTP packets monitoring
  42
  43 With C<-p> option you have to specify the transport protocol you want to
  44 monitor. Only explicit send and receive calls are gathered, so no
  45 forwarded packets won't be counted.
  46
  47 =back
  48
  49 =head2 Hostnames resolving
  50
  51 By default this program tries to asynchronously resolve all hostname for
  52 IP addresses in background. You can turn this off with C<-H> option.
  53 C<-P> option also disables service name lookup for the port numbers.
  54
  55 =head1 DISPLAY
  56
  57 Each line shows source and destination addresses with the traffic
  58 direction. If transport mode monitoring is active, then each address
  59 also contains the transport-level port. Unless explicitly disabled by
  60 command lines options, ports and IP addresses are tried to be resolved
  61 to human readable names.
  62
  63 Number of transferred bytes is shown nearby. There are three numbers:
  64 bytes passed for the last second, for last 5 seconds and for the 10
  65 seconds. All calculations are done in powers of two, so C<KB> actually
  66 means C<KiB>, but it is shortened to save the terminal space.
  67 Only the payload is considered, so transport/IP headers overhead is
  68 not counted. All entries are ordered by 10sec speed value.
  69
  70 Top section contains number of send/received packets (also as a tuple of
  71 1s/5s/10s) and total amount of send/received traffic with corresponding
  72 peak values.
  73
  74 =head1 AUTHOR
  75
  76 Sergey Matveev L<mailto:stargrave@stargrave.org>
  77
  78 =cut
  79
  80 use strict;
  81 use warnings;
  82
  83 my $VERSION = "0.1.0";
  84
  85 ########################################################################
  86
  87 use Getopt::Std;
  88 $Getopt::Std::STANDARD_HELP_VERSION = 1;
  89
  90 sub VERSION_MESSAGE { print "dmon $VERSION\n" }
  91
  92 my $HeightDefault = 40;
  93 my %Opts = (h => $HeightDefault);
  94
  95 sub HELP_MESSAGE {
  96     print "Usage: $0 [{-d|-D}] [-h HEIGHT] [-H] [-P]
  97     {-p [tcp|udp|udplite|sctp] | ifname0 ifname1 ...}
  98 -d -- output only generated DTrace script
  99 -D -- take input from stdin, not summoned DTrace
 100 -h -- set output height, by default it is $HeightDefault
 101 -H -- do not lookup host names
 102 -P -- do not lookup service names
 103 -p -- do not collect IP packets, but specified protocol ones
 104 ";
 105 }
 106
 107 getopts "dDh:HPp:", \%Opts;
 108 if ((not exists $Opts{p}) and ($#ARGV < 0)) { die HELP_MESSAGE }
 109 $Opts{h}--;
 110
 111 #########################################################################
 112
 113 use File::Temp qw/tempfile/;
 114 my ($dfh, $dfn) = tempfile();
 115 END { unlink $dfn if defined $dfn }
 116 my $Proto = (defined $Opts{p}) ? $Opts{p} : "ip";
 117 print $dfh "
 118 #pragma D option quiet
 119 #pragma D option switchrate=10Hz
 120 ";
 121 my $tick1secT = '
 122     printa("T %@d %@d %@d %@d\n", @rxpkts, @txpkts, @rxbytes, @txbytes);
 123     clear(@rxpkts);
 124     clear(@txpkts);
 125     clear(@rxbytes);
 126     clear(@txbytes);
 127 ';
 128 if ($Proto eq "ip") {
 129     my $conds = join " || ", map { "args[3]->if_name == \"$_\"" } @ARGV;
 130     sub ipprobe {
 131         my ($probe, $dir) = @_;
 132         print $dfh "
 133 $probe
 134 /$conds/
 135 {
 136     @" . $dir . "[args[2]->ip_saddr, args[2]->ip_daddr] = sum(args[2]->ip_plength);
 137     \@${dir}pkts = count();
 138     \@${dir}bytes = sum(args[2]->ip_plength);
 139 }\n";
 140     }
 141     ipprobe "ip:::send", "tx";
 142     ipprobe "ip:::receive", "rx";
 143     print $dfh "
 144 profile:::tick-1sec
 145 {
 146     printa(\"< %s %s %\@d\\n\", \@rx);
 147     trunc(\@rx);
 148     printa(\"> %s %s %\@d\\n\", \@tx);
 149     trunc(\@tx);
 150     $tick1secT
 151 }\n";
 152 } else {
 153     sub nonipprobe {
 154         my ($probe, $dir) = @_;
 155         print $dfh "
 156 $probe
 157 {
 158     @" . $dir . "[args[2]->ip_saddr,
 159         args[4]->${Proto}_sport,
 160         args[2]->ip_daddr,
 161         args[4]->${Proto}_dport] = sum(args[2]->ip_plength);
 162     \@${dir}pkts = count();
 163     \@${dir}bytes = sum(args[2]->ip_plength);
 164 }\n";
 165     }
 166     nonipprobe "${Proto}:::send", "tx";
 167     nonipprobe "${Proto}:::receive", "rx";
 168     print $dfh "
 169 profile:::tick-1sec
 170 {
 171     printa(\"< [%s]:%d [%s]:%d %\@d\\n\", \@rx);
 172     trunc(\@rx);
 173     printa(\"> [%s]:%d [%s]:%d %\@d\\n\", \@tx);
 174     trunc(\@tx);
 175 $tick1secT\n}\n";
 176 }
 177
 178 ########################################################################
 179
 180 my @sizePrefix = ("E", "P", "T", "G", "M", "K");
 181 my @countBound = (1e18, 1e15, 1e12, 1e9, 1e6, 1e3);
 182 my @sizeBound = (1<<60, 1<<50, 1<<40, 1<<30, 1<<20, 1<<10);
 183
 184 sub human {
 185     my ($s, $suffix, $bounds) = @_;
 186     foreach my $i (0 .. $#{$bounds}) {
 187         next if $s < @{$bounds}[$i];
 188         return sprintf "%.2f%s%s", $s / @{$bounds}[$i], $sizePrefix[$i], $suffix;
 189     }
 190     return "$s$suffix";
 191 }
 192
 193 sub humanCount { return human shift, "", \@countBound }
 194 sub humanSize { return human shift, "B", \@sizeBound }
 195
 196 ########################################################################
 197
 198 use Socket qw(AF_INET AF_INET6 inet_pton);
 199
 200 sub gethost {
 201     my $host = shift;
 202     my $family = (index($host, ":") == -1) ? AF_INET : AF_INET6;
 203     my $packed = inet_pton $family, $host;
 204     my @addr = gethostbyaddr $packed, $family;
 205     return (@addr > 0) ? $addr[0] : "[$host]";
 206 }
 207
 208 use threads;
 209 use threads::shared;
 210 my %HostCache :shared;
 211 my $ResolverQueue;
 212
 213 unless (defined $Opts{H}) {
 214     use Thread::Queue;
 215     $ResolverQueue = Thread::Queue->new();
 216     $ResolverQueue->limit = 0;
 217     threads->create(sub {
 218         while (my $host = $ResolverQueue->dequeue()) {
 219             my $name = gethost $host;
 220             lock %HostCache;
 221             $HostCache{$host} = $name;
 222         }
 223     })->detach();
 224 }
 225
 226 ########################################################################
 227
 228 my %ServCache;
 229
 230 sub humanHost {
 231     my $pair = shift;
 232     my ($host, $port);
 233     if ($Proto eq "ip") {
 234         $host = $pair;
 235     } else {
 236         my $i = rindex($pair, ":");
 237         $host = substr $pair, 1, $i-2;
 238         $port = substr $pair, $i+1;
 239     }
 240
 241     my $name;
 242     if ($Opts{H}) {
 243         $name = "[$host]";
 244     } else {
 245         {
 246             lock %HostCache;
 247             $name = $HostCache{$host};
 248         }
 249         unless (defined $name) {
 250             $ResolverQueue->enqueue($host);
 251             $name = $host;
 252         }
 253     }
 254     if ($Proto eq "ip") { return $name };
 255
 256     my $serv;
 257     if ($Opts{P}) {
 258         $serv = $port;
 259     } else {
 260         $serv = $ServCache{$port};
 261         unless (defined $serv) {
 262             $serv = getservbyport $port, $Proto;
 263             unless (defined $serv) { $serv = $port }
 264             $ServCache{$port} = $serv;
 265         }
 266     }
 267     return "$name:$serv";
 268 }
 269
 270 ########################################################################
 271
 272 sub agg1510 {
 273     my $sum = $_[0];
 274     my @r = ($sum);
 275     foreach (@_[1 .. 4]) { $sum += $_ }
 276     push @r, int($sum / 5);
 277     foreach (@_[5 .. 9]) { $sum += $_ }
 278     push @r, int($sum / 10);
 279     return @r;
 280 }
 281
 282 my (@allRxPktsAgg, @allTxPktsAgg);
 283 my (@allRxBytesAgg, @allTxBytesAgg);
 284 my @totalBytesAgg;
 285 my ($allRxBytesPeak, $allTxBytesPeak, $totalBytesPeak) = (0, 0, 0);
 286 format STDOUT_TOP =
 287 Rx: @||||||  @||||||  @||||||    @||||||  @||||||  @||||||    peak: @||||||
 288 humanCount($allRxPktsAgg[0]), humanCount($allRxPktsAgg[1]), humanCount($allRxPktsAgg[2]), humanSize($allRxBytesAgg[0]), humanSize($allRxBytesAgg[1]), humanSize($allRxBytesAgg[2]), humanSize($allRxBytesPeak)
 289 Tx: @||||||  @||||||  @||||||    @||||||  @||||||  @||||||    peak: @||||||
 290 humanCount($allTxPktsAgg[0]), humanCount($allTxPktsAgg[1]), humanCount($allTxPktsAgg[2]), humanSize($allTxBytesAgg[0]), humanSize($allTxBytesAgg[1]), humanSize($allTxBytesAgg[2]), humanSize($allTxBytesPeak)
 291 Total:                           @||||||  @||||||  @||||||    peak: @||||||
 292 humanSize($allRxBytesAgg[0] + $allTxBytesAgg[0]), humanSize($allRxBytesAgg[1] + $allTxBytesAgg[1]), humanSize($allRxBytesAgg[2] + $allTxBytesAgg[2]), humanSize($totalBytesPeak)
 293 ------------------------------------------------------------------------------------------------------------------------
 294 .
 295
 296 my ($left, $dir, $right, $agg);
 297 format =
 298 @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>... @| @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<...  @||||||  @||||||  @||||||
 299 humanHost($left), $dir, humanHost($right), humanSize($agg->[0]), humanSize($agg->[1]), humanSize($agg->[2])
 300 .
 301
 302 ########################################################################
 303
 304 close $dfh;
 305 my $dexec;
 306 if ($Opts{d}) {
 307     open $dexec, "<", "$dfn" or die "$!";
 308     while (<$dexec>) { print }
 309     exit;
 310 }
 311 if ($Opts{D}) {
 312     $dexec = \*STDIN;
 313 } else {
 314     open $dexec, "-|", "dtrace -s $dfn" or die "$!";
 315     sleep 1;
 316 }
 317 unlink $dfn;
 318
 319 my %bytes = ("<" => {}, ">" => {});
 320 my %seen = ("<" => {}, ">" => {});
 321 my @allRxPkts = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
 322 my @allTxPkts = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
 323 my @allRxBytes = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
 324 my @allTxBytes = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
 325 while (<$dexec>) {
 326     next unless /^[<>T]/;
 327     my @cols = split;
 328     if ($cols[0] eq "T") {
 329         unshift @allRxPkts, $cols[1]; pop @allRxPkts;
 330         unshift @allTxPkts, $cols[2]; pop @allTxPkts;
 331         unshift @allRxBytes, $cols[3]; pop @allRxBytes;
 332         unshift @allTxBytes, $cols[4]; pop @allTxBytes;
 333         if ($cols[3] > $allRxBytesPeak) { $allRxBytesPeak =  $cols[3] }
 334         if ($cols[4] > $allTxBytesPeak) { $allTxBytesPeak =  $cols[4] }
 335         if (($cols[3] + $cols[4]) > $totalBytesPeak) {
 336             $totalBytesPeak = $cols[3] + $cols[4];
 337         }
 338         @allRxPktsAgg = agg1510 @allRxPkts;
 339         @allTxPktsAgg = agg1510 @allTxPkts;
 340         @allRxBytesAgg = agg1510 @allRxBytes;
 341         @allTxBytesAgg = agg1510 @allTxBytes;
 342
 343         my @res;
 344         foreach my $dir (keys %bytes) {
 345             foreach my $src (keys %{$bytes{$dir}}) {
 346                 foreach my $dst (keys %{$bytes{$dir}{$src}}) {
 347                     my $vals = $bytes{$dir}{$src}{$dst};
 348                     if ((not exists $seen{$dir}{$src}) or
 349                         (not exists $seen{$dir}{$src}{$dst})) {
 350                         unshift @{$vals}, 0;
 351                     }
 352                     if (@{$vals} > 10) {
 353                         $bytes{$dir}{$src}{$dst} = [@{$vals}[0 .. 9]];
 354                     }
 355                     my @r = ($dir eq "<") ? ($dst, "<=", $src) : ($src, "=>", $dst);
 356                     push @r, [agg1510 @{$vals}];
 357                     if ($r[-1][-1] == 0) {
 358                         delete $bytes{$dir}{$src}{$dst};
 359                         next;
 360                     }
 361                     push @res, \@r;
 362                 }
 363             }
 364         }
 365         @res = sort { $b->[-1][2] <=> $a->[-1][2] } @res;
 366         printf "\033[H\033[J";
 367         $- = 0;
 368         foreach (@res[0 .. $Opts{h}]) {
 369             last unless defined;
 370             ($left, $dir, $right, $agg) = @{$_};
 371             write;
 372         }
 373         %seen = ("<" => {}, ">" => {});
 374         next;
 375     }
 376     unless (exists $bytes{$cols[0]}{$cols[1]}) {
 377         %{$bytes{$cols[0]}{$cols[1]}} = ();
 378     }
 379     unless (exists $bytes{$cols[0]}{$cols[1]}{$cols[2]}) {
 380         @{$bytes{$cols[0]}{$cols[1]}{$cols[2]}} = (0, 0, 0, 0, 0, 0, 0, 0, 0);
 381     }
 382     unshift @{$bytes{$cols[0]}{$cols[1]}{$cols[2]}}, $cols[3];
 383     unless (exists $seen{$cols[0]}{$cols[1]}) {
 384         %{$seen{$cols[0]}{$cols[1]}} = ();
 385     }
 386     $seen{$cols[0]}{$cols[1]}{$cols[2]} = 1;
 387 }