#!/usr/bin/perl

# constants
$CONFIG_FILE = "/usr/local/etc/mynetworks.conf";
$USER = "daemon";
$IDENT = "trafficd";
$PID_FILE = "/var/run/$IDENT.pid";
$FACILITY = "local3";
$RAWLOG = "/var/tmp/rawlog.txt";

# modules
use Net::Pcap findalldevs, lookupnet, open_live, loop, breakloop;
use POSIX;
use Sys::Syslog ":DEFAULT", setlogsock;

# set by signal handlers
$global_state = 0;

# close terminal, auto-flush on
close(STDIN);
close(STDOUT);
$| = 1;

# find all network interfaces visible to libpcap
@devs = findalldevs(\%devinfo, \$err);
die "findalldevs(): $err" if $err;

# get desired interface from the command line
$dev = shift;
die "usage: $0 <interface>\n\npossible interfaces:\n\n" .
    join("", map { "$_:\t$devinfo{$_}\n" } @devs) unless exists $devinfo{$dev};

# gather network info
&mydie("%s: %s", $dev, $err) if lookupnet($dev, \$addr, \$mask, \$err);

# fetch user info
($name,$passwd,$uid,$gid,@rest) = getpwnam($USER) or die "no such user: $USER";

# load mynetworks
$err = &load_mynetworks($CONFIG_FILE, \@mynetworks);
die $err if $err;

# check if we are already running
if (open(FH, $PID_FILE)) {
  $pid = <FH>;
  close(FH);
  $pid =~ s/[^\d]//sgio;
  die "already running (pid $pid)" if kill(0, $pid);
}

# fork, parent exits
$pid = fork();
die "fork(): $!" unless defined $pid;
exit(0) if $pid;
setsid();

# log to syslog instead of console
setlogsock("unix") or die "setlogsock(): $!";
openlog($IDENT, "ndelay,pid", $FACILITY) or die "openlog(): $!";
close(STDERR);

# save pid
open(FH, ">$PID_FILE") or &mydie("%s: %m", $PID_FILE);
print FH "$$\n";
close(FH);

# open interface
$pcap = open_live($dev, 10000, 0, 2000, \$err);
&mydie("%s: %s", $dev, $err) if ($err || !$pcap);

# drop root privileges
&mydie("can not change gid to $gid: %s", $!) unless setgid($gid);
&mydie("can not change uid to $uid: %s", $!) unless setuid($uid);

# setup signal handlers
$SIG{HUP} = sub {
  &myinfo("%s", "SIGHUP received, reloading configuration as next paket arrives");
  $global_state = 1;
};
$SIG{TERM} = sub {
  &myinfo("%s", "SIGTERM received, shutting down as next paket arrives");
  $global_state = 2;
};

# start capture
&myinfo("starting capture on %s (%s/%s)",
        $dev, &inet_ntoa($addr), &inet_ntoa($mask));
&myinfo("mynetworks: %s", join(", ", @mynetworks));
open(RAWLOG, ">>$RAWLOG") or &mydie("%s: %m", $RAWLOG);
my $dat = {
  pcap => $pcap,
  start => time(),
  pkt => 0,
  external => 0,
  internal => 0,
  configfile => $CONFIG_FILE,
  mynetworks => \@mynetworks,
  rawlog => \*RAWLOG,
};
&mydie("loop() error") if (loop($pcap, -1, \&packet_handler, $dat) == -1);
&mystats($dat, "exiting after ");
close(RAWLOG);
pcap_close($pcap);

### local subroutines ####

# callback
sub packet_handler ()
{
  my ($dat, $hdr, $pkt) = @_;
  my ($len, $err);

  if ($global_state == 1) {
    &myinfo("current mynetworks: %s", join(", ", @{$dat->{mynetworks}}));
    $err = &load_mynetworks($dat->{configfile}, $dat->{mynetworks});
    &mywarn("%s", $err) if $err;
    &myinfo("new mynetworks: %s", join(", ", @{$dat->{mynetworks}}));
    $global_state = 0;
  }
  if ($global_state == 2) {
    breakloop($dat->{pcap});
    $global_state = 0;
  }

  $len = $hdr->{caplen};

  $err = &consume_ethernet(\$pkt, \$len, \%ethernet);
  if ($err) {
    &mywarn("%s", $err);
    return;
  }
  return unless ($ethernet{type} == 0x800);

  $err = &consume_ipv4(\$pkt, \$len, \%ip);
  if ($err) {
    &mywarn("%s", $err);
    return;
  }

  my $type = ((&is_in_my_networks($ip{src}, $dat->{mynetworks}) &&
               &is_in_my_networks($ip{dst}, $dat->{mynetworks})) ?
               "internal" : "external");
  $dat->{$type} += $ip{len};

  my $rawlog = $dat->{rawlog};
  flock($rawlog, 2) or &mydie("can not lock %s: %m", $rawlog);
  seek($rawlog, 0, 2) or &mydie("can not seek to end of %s: %m", $rawlog);
  print $rawlog "time:" . time() . " type:$type caplen:$hdr->{caplen} " .
                "esrc:$ethernet{src} edst:$ethernet{dst} " .
                "isrc:$ip{src} idst:$ip{dst} ilen:$ip{len}\n";
  flock($rawlog, 8) or &mydie("can not unlock %s: %m", $rawlog);
  &mystats($dat) unless (++$dat->{pkt} % 100);
}

# parse ip paket
sub consume_ipv4 ()
{
  my $pkt = shift;
  my $len = shift;
  my $ret = shift;

  return "paket length %len too small for ip version + header length"
    if ($$len < 2);

  my $ver = unpack("C", substr($$pkt, 0, 1));
  $hdr_len = ($ver & 0xf) * 4;
  $ver >>= 4;

  return "unhandled version $ver ip paket" if ($ver != 4);
  return "paket length $$len too small for header length $hdr_len"
    if ($$len < $hdr_len);

  my $tot_len = unpack("n", substr($$pkt, 2, 2));

  return "paket length $$len too small for total length $tot_len"
    if ($$len < $tot_len);
  return "header length $hdr_len larger than total length $tot_len"
    if ($tot_len < $hdr_len);

  $ret->{len} = $tot_len;
  $ret->{src} = join(".", unpack("C[4]", substr($$pkt, 12, 4)));
  $ret->{dst} = join(".", unpack("C[4]", substr($$pkt, 16, 4)));

  substr($$pkt, 0, $tot_len);
  $$len -= $tot_len;

  return "";
}

# parse ethernet frame
sub consume_ethernet ()
{
  my $pkt = shift;
  my $len = shift;
  my $ret = shift;

  return "frame length $$len too small for ethernet" if ($$len < 14);

  $ret->{dst} = join(":", unpack("(H[2])[6]", substr($$pkt, 0, 6, "")));
  $ret->{src} = join(":", unpack("(H[2])[6]", substr($$pkt, 0, 6, "")));
  $ret->{type} = unpack("n", substr($$pkt, 0, 2, ""));
  $$len -= 14;

  return "";
}

# load mynetworks
sub load_mynetworks ()
{
  my $fn = shift;
  my $mynetworks = shift;

  @$mynetworks = ();
  return "$fn: $!" unless open(FH, $fn);
  while (<FH>) {
    s/\r|\n//sgio;
    next if /^#/o;
    next if /^;/o;
    next if /^\s*$/o;
    push @$mynetworks, $_;
  }
  close(FH);
  return "";
}

# check if ip address belongs to my networks
sub is_in_my_networks ()
{
  my $ip = shift;
  my $mynetworks = shift;
  foreach (@$mynetworks) {
    my ($net, $mask) = split(/\//, $_);
    return 1 if (&inet_aton($ip, $mask) == &inet_aton($net, $mask));
  }
  return 0;
}

# integer to dotted ip address
sub inet_ntoa ()
{
  my $addr = shift;
  my @octet = ();

  for (my $i = 3; $i >= 0; $i--) {
    $octet[$i] = $addr & 0xff;
    $addr >>= 8;
  }

  return join(".", @octet);
}

# dotted ip address with mask to integer
sub inet_aton ()
{
  my $addr = 0;

  foreach (split(/\./, $_[0])) {
    $addr = ($addr << 8) + $_;
  }
  return ($addr & (0xffffffff << (32 - $_[1])));
}

# nice output
sub format_traffic ()
{
  my $bytes = shift;
  my $suffix;
  foreach ("B", "kB", "MB", "GB") {
    $suffix = $_;
    return "$bytes$suffix" unless $bytes > 1000;
    $bytes = int(($bytes * 100) / 1000) / 100;
  }
  return "$bytes$suffix";
}

# logging functions
sub mylog ()
{
  my ($lvl, $fmt, @var) = @_;
  syslog($lvl, $fmt, @var);
}

sub myinfo ()
{
  &mylog(LOG_INFO, @_);
}

sub mywarn ()
{
  &mylog(LOG_WARNING, @_);
}

sub mydie ()
{
  my $fmt = shift;
  &mylog(LOG_ERR, $fmt, @_);
  exit(1);
}

sub mystats ()
{
  my $dat = shift;
  my $prefix = shift;
  &myinfo($prefix . "running since %s (for %llu seconds); pakets: %llu; " .
          "internal traffic: %s; external traffic: %s",
          scalar localtime($dat->{start}), time() - $dat->{start}, $dat->{pkt},
          &format_traffic($dat->{internal}),
          &format_traffic($dat->{external}));
}