#!/usr/local/bin/perl -T
#
# Compute stats by protocol from a tcpdump.
#
# Copyright (c) 1997 Renaud Waldura # Wed Feb 26 14:15:42 1997
#

use Socket;
use Fcntl;
use FileHandle;


# the configuration file
$CONFIG_FILE = '/home/renaud/etc/net-stats.conf';

$PROGNAME = 'Net-Stats';	# program name
$VERSION = '3.5';		# program version

@X11 = (6000 .. 6063);		# X11 ports

%SERVICENAME = ();		# service names cache
@SERVICENAME{@X11} = ('x11') x @X11;

%HOSTNAME = ();                 # host names cache
$HOSTNAME{'127.0.0.1'} = 'localhost';

undef $ENV{'PATH'};
undef $ENV{'CDPATH'};		# security

$| = 1;				# debug


# read in configuration
%CONF = ();
read_config(\%CONF, $CONFIG_FILE) 
   or die "Error in configuration file $CONFIG_FILE";

init(\%CONF);			# initialize program

# install termination handler
my @signals = ('HUP', 'INT', 'TERM');
@SIG{@signals} = (\&sig_handler) x @signals;

main();				# infinite loop

done();				# cleanup


sub main
{    
   my %packets = ( 'icmp_cnt'    => 0, 'icmp'    => {}, 
		   'arp_cnt'     => 0, 'arp'     => {}, 
                   'tcp_cnt'     => 0, 'tcp'     => {},
		   'unknown_cnt' => 0, 'unknown' => [],
		 );

   my %data = ( 'start_time'  => time(),
	        'tcp_bytes'   => 0,
	        'second_peak' => 0,
                'packets'     => \%packets
              );

   my $ip = '\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}';      # IP address pattern

   my($new_second, $old_second, $second_bytes, $n) = (0) x 4;
                
   while (<TCPDUMP>)		# this loop is terminated by signal only
   {
      $new_second = $1 if (s/^\d\d:\d\d:(\d\d).\d+ //);

      if ($new_second != $old_second)
      {
	 $data{'second_peak'} = $second_bytes 
            if ($second_bytes > $data{'second_peak'});
	 $second_bytes = 0;
      }
      $old_second = $new_second;

      if (($host) = /^arp [\w-]+ ($ip) /o)                        # ARP
      {
	 count_arp($packets{'arp'}, $host);
	 $packets{'arp_cnt'}++;
      }
      elsif (($src_host, $dest_host) = /^($ip) > ($ip): icmp: /o) # ICMP
      {
	 count_icmp($packets{'icmp'}, $src_host, $dest_host);
	 $packets{'icmp_cnt'}++;
      }
      elsif (($src_host, $src_port, $dest_host, $dest_port, $details)
	        = /^($ip)\.(\d+) > ($ip)\.(\d+): (.+)$/o)         # TCP/UDP
      { 
	 my($pkt_bytes) = ($details =~ /\((\d+)\)/);

	 count_tcp($packets{'tcp'}, 
		   $src_host, $src_port, $dest_host, $dest_port, 
		   $pkt_bytes); 

	 $data{'tcp_bytes'} += $pkt_bytes;
	 $second_bytes += $pkt_bytes;

	 $packets{'tcp_cnt'}++;
      }
      else						# unknown
      {
	 push(@{$packets{'unknown'}}, $_);
	 $packets{'unknown_cnt'}++;
      }

      if (++$n % $CONF{'purge_tables'} == 0)		# purge tables 
      {
	 $n = 0;
	 purge_tables(\%packets, \%data, @CONF{'tcp_max', 'icmp_max'});
      }

      if ($CONF{'_needs_update'}) # re-read configuration 
      {
	 my %new_config = ();

	 if (read_config(\%new_config, $CONFIG_FILE))
	 {
	    done();		  # cleanup config-dependent objects
	    init(\%new_config);
	    %CONF = %new_config;
	 }
	 else
	 {
	    warn "Error in configuration file $CONFIG_FILE; re-using old values";	  
	 }
      }  

      next unless ($client = accept(CLIENT, SERVER)); # client connected

print "Connection from ", host_info($client), " at ", scalar localtime(), "\n";

      # make sure data is delivered before the socket is closed
      linger_on_close(\*CLIENT); 

      if (allowed_host($client))                      # client "authenticated"
      {
	 print_data(\*CLIENT, \%packets, \%data);
      }
      else
      {
	 access_denied(\*CLIENT, $client);            # sorry dude
      }

      close CLIENT;				      # close client socket
   }
}

sub sig_handler
{
   my($signal) = @_;

print "Caught SIG$signal\n";

   exit unless ($signal eq 'HUP'); # executes END{}

   $CONF{'_needs_update'} = 1;	   # SIGHUP received
}

sub init
{
   my($config) = @_;

   open_socket($config->{'port'});   
   open_tcpdump($config->{'tcpdump'}, $config->{'tcpdump_opts'});
}

sub open_socket
{
   my($port) = @_;
   my $proto = getprotobyname('tcp');

   # TCP socket
   socket(SERVER, PF_INET, SOCK_STREAM, $proto) 
      or die "Cannot create socket: $!";

   # so that accept() in main loop above won't block
   fcntl(SERVER, F_SETFL, O_NONBLOCK)           
      or die "Cannot fcntl socket: $!";

   # the old server socket might stick around for a while even after 
   # closing it; make sure that, on restart (SIGHUP received), we'll
   # succeed in binding the new server socket to the same port
   setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1)
      or warn "Cannot set socket option SO_REUSEADDR: $!";

   # bind socket to the server port on all interfaces
   bind(SERVER, sockaddr_in($port, INADDR_ANY)) 
      or die "Cannot bind socket to port $port: $!";

   # connections queue
   listen(SERVER, SOMAXCONN)                            
      or die "Cannot listen to socket: $!";
}

sub linger_on_close
{
   my($socket) = @_;
   my $linger = pack('ii', 1, 120);                 # BSD struct linger

   setsockopt(CLIENT, SOL_SOCKET, SO_LINGER, $linger)
      or warn "Cannot set socket option SO_LINGER: $!";
}

sub open_tcpdump
{
   my($cmd) = join(' ', @_);

   open(TCPDUMP, "$cmd |") or die "Cannot execute '$cmd': $!";
}

sub done
{
   close SERVER  or warn "Cannot close socket: $!";   # close server socket
   close TCPDUMP or warn "Cannot close tcpdump: $!";  # terminate tcpdump
}

END
{
    done();                      # cleanup
}

sub purge_tables
{
   my($packets, $data, $tcp_max, $icmp_max) = @_;

   purge_table($packets->{'tcp'}, $data->{'tcp_bytes'})
      if (keys %{$packets->{'tcp'}} > $tcp_max);

   purge_table($packets->{'icmp'}, $packets->{'icmp_cnt'})
      if (keys %{$packets->{'icmp'}} > $icmp_max);
}

sub purge_table
{
   my($h, $total) = @_;
   
   foreach (keys %$h)		# remove entries < 1%
   {
      delete $h->{$_} if (percent($h->{$_}, $total) < 1);
   }
}

sub count_arp
{
   my($h, $host) = @_;
   $h->{$host}++;
}

sub count_icmp
{
   my($h, $src, $dest, $data) = @_;
   $h->{"$src > $dest"}++;
}

sub count_tcp
{
   my($h, $src_host, $src_port, $dest_host, $dest_port, $bytes) = @_;
   my($server_port);
   
   # the server port is the smallest port number unless in the X11 range.
   # (this is not always true, but it's enough for now)
   if ($src_port >= $X11[0] && $src_port <= $X11[$#X11])
   {
      $server_port = $src_port;
   }
   elsif ($dest_port >= $X11[0] && $dest_port <= $X11[$#X11])
   {
      $server_port = $dest_port;
   }
   else
   {
      $server_port = ($src_port < $dest_port) ? $src_port : $dest_port;
   }
   
   # increment counts
   $h->{$server_port} += $bytes;
}

sub allowed_host
{
   my($host) = @_;
   my($hname, $haddr) = host_info($host);
   my @haddr = split(/\./, $haddr);

   foreach (@{$CONF{'allowed_hosts'}})
   {
      my($addr, $mask) = @$_;
      my @addr = split(/\./, $addr);
      my @mask = split(/\./, $mask);
      return 1 if (mask_eq(\@haddr, \@addr, \@mask));
   }

   return 0;
}

sub host_info
# returns host name and address (in printable format) from a struct
# as returned by accept()
{
   my($host) = @_;
   my($port, $addr) = sockaddr_in($host);
   my $hostaddr = inet_ntoa($addr);
   my $hostname = _gethostbyaddr($hostaddr);
   return ($hostname, $hostaddr);
}

sub host_name
# returns host name, or address if unable to resolve
{
   my($hostaddr) = @_;
   my $hostname = _gethostbyaddr($hostaddr);
   return ($hostname) ? $hostname : $hostaddr;
}

sub service_name
# returns service name, or port number if unable to resolve
{
    my($servport) = @_;
    my $servname = _getservbyport($servport);
    return ($servname) ? $servname : $servport;
}

sub _gethostbyaddr
# caches resolved host names; attempts resolution only once
{
   my($addr, $type) = @_;
   return $HOSTNAME{$addr} if (defined $HOSTNAME{$addr});

   my $hostname = gethostbyaddr(inet_aton($addr), $type || AF_INET);

   return $HOSTNAME{$addr} = ($hostname || '');
}

sub _getservbyport
# caches resolved service names; attempts resolution only once
{
    my($port, $proto) = @_;
    return $SERVICENAME{$port} if (defined $SERVICENAME{$port});

    my $servname = getservbyport($port, $proto || 'tcp');
    return $SERVICENAME{$port} = ($servname || '');
}

sub mask_eq
# returns true if ($haddr & $mask) == $addr
{
   my($haddr, $addr, $mask) = @_;
   my $eq = 1;
   
   for $i (0..3)
   {
      # force numerical, otherwise Perl does an ASCII and :(
      my($a, $b, $c) = map {$_ + 0} ($haddr->[$i], $addr->[$i], $mask->[$i]);
      
      $eq &&= ($a & $c) == $b;
   }
   return $eq;
}

sub access_denied
{
   my($f, $host) = @_;
   my($hname, $haddr) = host_info($host);
   my $now = localtime();
   
   print $f <<EOT;
HTTP/1.0 403 Forbidden
Date: $now
Server: $PROGNAME/$VERSION
Content-type: text/html

<html>
<head>
<title>Forbidden</title>
<body>
<h1>Forbidden</h1>
<p>
Host $haddr ($hname) is not allowed access to this service.
</p>
</html>
EOT
}

sub print_data
{
   my($f, $pkts, $data) = @_;

   my $start = $data->{'start_time'};
   my $now = time();

   my $s1 = localtime($start);
   my $s2 = localtime($now);
   
   my $total_pkts = 0; 
   map {$total_pkts += $pkts->{$_}} grep(/_cnt$/, keys %$pkts);

   my $unknown_pkts = $pkts->{'unknown_cnt'};

   my $total_known_pkts = $total_pkts - $unknown_pkts;

   my $pps = round($total_pkts / ($now - $start));
   
   print $f <<EOT;			# start of document
HTTP/1.0 200 OK
Date: $now
Server: $PROGNAME/$VERSION
Content-type: text/html

<html>
<head>
<title>Network Stats</title>
<body>
<h1>Network Stats</h1>
<p>
From $s1 to $s2 (now)
<p>
$total_pkts total packets<br>
Average $pps packets/sec
</p>
EOT

   my $bytes = $data->{'tcp_bytes'};
   my $peak = $data->{'second_peak'};

   print_bandwidth($f, $start, $now, $peak, $bytes);

   print $f "<h2>By Protocol</h2>\n";

   print_tcp($f, $pkts->{'tcp'}, $pkts->{'tcp_cnt'}, $total_known_pkts, $bytes);
   print_icmp($f, $pkts->{'icmp'}, $pkts->{'icmp_cnt'}, $total_known_pkts);
   print_arp($f, $pkts->{'arp'},  $pkts->{'arp_cnt'},  $total_known_pkts);
   print_unknown($f, $pkts->{'unknown'}, $unknown_pkts);

   print $f <<EOT;			# end of document
<hr>
<address>$PROGNAME $VERSION - $s2</address>
</html>
EOT
}

sub print_bandwidth
{
   my($f, $start, $now, $peak, $bytes) = @_;
   my $total_bandwidth = $CONF{'bandwidth'};
   
   $peak *= 8;
   my $pp = percent($peak, $total_bandwidth);
   $peak = bytes2str($peak);
   
   my $average = ($bytes * 8) / ($now - $start);
   my $ap = percent($average, $total_bandwidth);
   $average = bytes2str($average);

   $bytes = bytes2str($bytes);

   print $f <<EOT;
<h2>Approximate Bandwidth</h2>
<p>
Total $bytes bytes transferred with TCP/UDP
<p>
<table cellpadding=3>
<tr>
<th>Bandwidth
<th>bits/sec
<th>%
<tr>
<td>Peak
<td>$peak
<td>$pp
<tr>
<td>Average
<td>$average
<td>$ap
</table>
</p>
EOT
}

sub print_tcp
{
   my($f, $h, $n, $total, $total_bytes) = @_;
   my $p = percent($n, $total);
   my $ps = bytes2str(int($total_bytes / $n));

   print $f <<EOT;			# TCP table
<h3>TCP/UDP</h3>
<p>
$n packets, $p% of total known packets <br>
Average packet size: $ps bytes
<p>
<table cellpadding=3>
<tr>
<th>Service
<th>Bytes
<th>%
<th>
EOT
  
   my $gbm = $CONF{'graphbar_max'};

   for $service (sort {$h->{$b} <=> $h->{$a}} keys %$h)
   {
      my $serv_name = service_name($service);
      my $bytes = $h->{$service};
      my $p = percent($bytes, $total_bytes);
      my $bs = bytes2str($bytes);
      my $bar = "[]" x int($bytes * $gbm / $total_bytes);
      
      print $f <<EOT;		# one row
<tr>
<td>$serv_name
<td>$bs
<td>$p
<td><font size="-1">$bar</font>
EOT
   }

   print $f <<EOT;			# end of table
</table>
</p>
EOT
}

sub print_icmp
{
   my($f, $h, $n, $total) = @_;
   my $p = percent($n, $total);
   
   print $f <<EOT;			# ICMP table
<h3>ICMP</h3>   
<p>
$n packets, $p% of total known packets
<p>
<table cellpadding=3>
<tr>
<th>Source
<th>Dest
<th>Count
EOT

   foreach (sort {$h->{$b} <=> $h->{$a}} keys %$h)
   {
      my($src_host, $dest_host) = map {host_name($_)} split / > /;
      
      print $f <<EOT;
<tr>
<td>$src_host
<td>$dest_host
<td>$h->{$_}
EOT
   }   

   print $f <<EOT;			# end of table
</table>
</p>
EOT
}

sub print_arp
{
   my($f, $h, $n, $total) = @_;
   my $p = percent($n, $total);
   
   print $f <<EOT;			# ARP table
<h3>ARP</h3>   
<p>
$n packets, $p% of total known packets
<p>
<table cellpadding=3>
<tr>
<th>Host
<th>Count
EOT

   foreach (sort {$h->{$b} <=> $h->{$a}} keys %$h)
   {
      my $host_name = host_name($_);

      print $f <<EOT;
<tr>
<td>$host_name
<td>$h->{$_}
EOT
   }
   
   print $f <<EOT;			# end of table
</table>
</p>
EOT
}

sub print_unknown
{
   my($f, $a, $n) = @_;

   print $f <<EOT;
<h3>Unknown Packets</h3>
<p>
$n packets
<p>
<dl>
EOT

   print $f map {"<dd>$_\n"} @$a;

   print $f <<EOT;		#  end of table
</dl>
</p>
EOT
}

sub bytes2str
{
   my($bytes) = @_;
   my($kilo, $mega, $giga, $tera);
   
   if (($kilo = $bytes / 1024) < 1)
      { return $bytes; } 
   elsif (($mega = $kilo / 1024) < 1) 
      { return round($kilo) . 'K'; } 
   elsif (($giga = $mega / 1024) < 1) 
      { return round($mega) . 'M'; }
   elsif (($tera = $giga / 1024) < 1) 
      { return round($giga) . 'G'; }
   else
      { return round($tera) . 'T'; }
}

sub percent
{
   my($frac, $total) = @_;
   return round(100 * $frac / $total);
}

sub round
{
   my($x) = @_;
   return int(10 * $x + 0.5) / 10;
}

sub read_config
{
   my($config, $file) = @_;
   my $ip = '\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}';	# IP address pattern

   open(CONF, $file) or die "Cannot open configuration file $file: $!";

   while (<CONF>)
   {
      next if (/^#/ || /^\s*$/);

      my($cmd, $arg, @args) = split;
      $cmd = lc $cmd;

      if ($cmd eq 'port'	 || 
	  $cmd eq 'bandwidth'	 || 
	  $cmd eq 'tcp_max'	 || 
	  $cmd eq 'icmp_max'	 || 
	  $cmd eq 'purge_tables' ||
	  $cmd eq 'graphbar_max')
      {
	 unless ($arg =~ /^(\d+)$/)
	 {
	    warn "Configuration directive '$cmd' expects number (got $arg)";
	    return 0;
         }
	 $config->{$cmd} = $1;
      }
      elsif ($cmd eq 'tcpdump' )
      {
	 unless ($arg =~ /^([\.\w\/-]+)$/ && -e $arg)
	 { 
	    warn "Configuration directive '$cmd' expects valid pathname (got $arg)";
	    return 0;
         }
	 $config->{$cmd} = $1;
      }
      elsif ($cmd eq 'tcpdump_opts')
      {
         my $options = join(' ', $arg, @args);

	 unless ($options =~ /^([-\w ]+)$/)
	 {
            warn "Configuration directive '$cmd' expects valid program options (got $options)";
	    return 0;
	 }
	 $config->{$cmd} = $1;
      }
      elsif ($cmd eq 'allow_hosts')
      {
         my $arg2 = pop @args;

	 unless ($arg =~ /^$ip$/o && $arg2 =~ /^$ip$/o)
	 {
	    warn "Configuration value '$arg/$arg2' is not a valid network number/mask";
	    return 0;
         }
	 push(@{$config->{'allowed_hosts'}}, [$arg, $arg2]);
      }
      else 
      {
	 warn "Invalid configuration directive '$cmd'";
	 return 0;
      }
   }
   close CONF;

   $config->{'_update'} = 0;	# configuration updated

   return 1;
}