#!/usr/local/bin/perl -wnT
#
# Copyright Hank Leininger <hlein@korelogic.com>

INIT
{
  $::V = '$Id: dbgrep,v 1.28 2008/05/21 19:24:50 hlein Exp $';
  $::V =~ s/^.*,v //; $::V =~ s/ .*//;
}

# Read a Dragon .db file, apply various filters to it (and clean up
# some occasional breakage of the file format :-) and spit it out.
# Usage should be similar to drep, with some bonuses--any number
# of -sip, -dip, etc arguments can be used (they will be ORed).
# In some ways usage is more grep-like than drep-like, where I
# just couldn't help myself.

# For performance, nearly everything is inlined; occasionally things
# are not done in the most straightforward/elegant way because it's
# faster otherwise.

INIT
{
  use strict;
  use Socket;
  $|=1;
  $::Negative = 0;
  $::FollowSessions = 0;
  $::CheckPackets = 0;
  while (@ARGV and $ARGV[0] =~ /^-([a-zA-Z0-9]+)$/) {
    shift(@ARGV);
    &Usage if ($1 eq 'h');
    if ($1 eq 'v') {
      $::Negative = 1;
      next;
    } elsif ($1 eq 'S') {
      $::FollowSessions = 1;
      next;
    } elsif ($1 eq 'C') {
      $::CheckPackets = 1;
      next;
    }
    my $arg = shift(@ARGV) || die "Option '$1' requires an argument\n";
    if ($1 eq 'e') {
      $::Events{$arg}++;
    } elsif ($1 eq 'ip') {
      $::Ips{$arg}++;
    } elsif ($1 eq 'sip') {
      $::Sips{$arg}++;
    } elsif ($1 eq 'dip') {
      $::Dips{$arg}++;
    } elsif ($1 eq 'port') {
      $::Ports{$arg}++;
    } elsif ($1 eq 'sport') {
      $::Sports{$arg}++;
    } elsif ($1 eq 'dport') {
      $::Dports{$arg}++;
    } elsif ($1 eq 'sensor') {
      $::Sensors{$arg}++;
    } elsif ($1 eq 'body') {
      $::Body{$arg}++;
    } elsif ($1 eq 'f') {
      my ($sig, $arg) = split(" ", $arg, 2);
      $sig =~ s/^\.//;
      $::Filters{$sig}{$arg}++;
    } elsif ($1 eq 'F') {
      &LoadFilters($arg);
    } else {
      die "Unknown option '$1'\n";
    }
  }

  &Usage if (scalar(@ARGV) and $ARGV[0] eq '--help');
  &Usage if (-t STDIN and not scalar(@ARGV));
  if (-t STDOUT)
  {
    warn "\nDo you really want to spam your console with binary junk?\n";
    warn "I'll give you 5 seconds to hit control-C...\n\n";
    sleep 5;
  }
  &SetupFilters;

  sub Usage
  {
    (my $basename = $0) =~ s%.*/%%;
    warn "  Usage: $basename [options] <dragon.db >new_dragon.db
     or: $basename [options] <dragon.db | dbcat

 options:    -e EVENT            Look for events with this name
             -ip ADDRESS         Look for traffic to or from this IP
             -sip ADDRESS        Look for traffic from this IP
             -dip ADDRESS        Look for traffic to this IP
             -port PORT          Look for traffic to or from this port
             -sport PORT         Look for traffic from this port
             -dport PORT         Look for traffic to this port
             -sensor SENSOR      Look for events from this sensor
             -body REGEX         Look for traffic matching this regex
             -f 'FILTER'         Match according to DragonFilter syntax:
	     			 'SIGNAME srchost 1.1.1.1 and dstport 80'
             -F FILE             Load DragonFilter list from FILE
             -C                  Check packets; print all invalid events
             -S                  Follow the Session for any matching packet
             -v                  Invert the sense of the match
                                     (discard matched events,
                                      and print unmatched)

 Note: only full IPs are supported, CIDR blocks are not :(

 Options can be repeated any number of times, in which case,
 the repeated option will be ORed (-e FOO -e BAR == 'FOO or BAR').
 One can always chain dbgrep's (dbgrep -someopts | dbgrep -otheropts)
 to do things which cannot be easily expressed by the above.

$basename version: $::V
";
    exit;
  }

  sub SetupFilters
  {
    foreach my $evt (keys %::Filters)
    {
      foreach my $filter (keys %{$::Filters{$evt}})
      {
        my $filter_parsed = &MakeFilter($filter);
        $::Filters{$evt}{$filter} = $filter_parsed;
      }
    }
  }

  sub MakeFilter
  {
    my $filter = shift;
    my $filter_orig = $filter;
    $filter =~ s/\s*tcp\s*/ \$prot == 6 /gi;
    $filter =~ s/\s*udp\s*/ \$prot == 17 /gi;
    $filter =~ s/\s*icmp\s*/ \$prot == 1 /gi;
    $filter =~ s/\s*srchost\s+([0-9.]+)/ \$sip eq '$1'/gi;
    $filter =~ s/\s*dsthost\s+([0-9.]+)/ \$dip eq '$1'/gi;
    $filter =~ s/\s*srcport\s+([0-9.]+)/ \$sport eq '$1'/gi;
    $filter =~ s/\s*dstport\s+([0-9.]+)/ \$dport eq '$1'/gi;
    $filter =~ s/\s*host\s+([0-9.]+)/ (\$sip eq '$1' || \$dip eq '$1')/gi;
    $filter =~ s/\s*port\s+([0-9.]+)/ (\$sport eq '$1' || \$dport eq '$1')/gi;

    my ($sHexNetwork, $sHexNetmask);
    $filter =~ s/\s*srcnet\s+([0-9.]+\/[0-9]+)/($sHexNetwork, $sHexNetmask) =
		&MakeCidr($1); sprintf(" (hex(\$hexsip) & hex('$sHexNetmask') == hex('$sHexNetwork'))")/gei;

    $filter =~ s/\s*dstnet\s+([0-9.]+\/[0-9]+)/($sHexNetwork, $sHexNetmask) =
		&MakeCidr($1); sprintf(" (hex(\$hexdip) & hex('$sHexNetmask') == hex('$sHexNetwork'))")/gei;

    $filter =~ s/\s*net\s+([0-9.]+\/[0-9]+)/($sHexNetwork, $sHexNetmask) =
		&MakeCidr($1); sprintf(" (hex(\$hexsip) & hex('$sHexNetmask') == hex('$sHexNetwork') or " .
					"hex(\$hexdip) & hex('$sHexNetmask') == hex('$sHexNetwork'))")/gei;

    $filter = '$match=0 unless (' . $filter . ');';
    return($filter);
  }

  sub MakeCidr
  {
    my $cidr = shift;

    $cidr =~ m{((?:\d{1,3}[.]){3}(?:\d{1,3}))/(\d{1,2})$} || die "bad CIDR '$cidr'\n";
    my ($sNetwork, $sMaskBits) = ($1, $2);

    my $sBits2Clear = 32 - $sMaskBits - 1;

    my $sNetMask = 0xffffffff;

    foreach my $sBit (0..$sBits2Clear)
    {
      $sNetMask ^= 1 << $sBit;
    }

    my $sHexNetwork = sprintf("%02x%02x%02x%02x", split(/\./, $sNetwork));
    my $sHexNetmask = sprintf("%08x", $sNetMask);

    return($sHexNetwork, $sHexNetmask);
  }

  sub LoadFilters
  {
    my $infile = shift;
    open(INFILE, "< $infile") || die "open '$infile' failed: $!\n";
    while(<INFILE>)
    {
      chomp;
      s/[#;].*//;
      my ($sig, $arg) = split(/\s+/, $_, 2);
      next unless ($arg);
      $sig =~ s/^\.//;
      $::Filters{$sig}{$arg}++;
    }
  }
  $/ = "AX:\n";
}

LINE:

my $entry = $_;
chomp;
# Sanity check, records should start with 'EV:'
my $info = $_;
next unless $info =~ s/^EV: ([^\n]+)\n//;
my $sensor = $1;
my $prefix = substr($_, 0, index($_, "\nAR: "));

my ($dir, $time, $si1, $si2, $si3, $si4, $di1, $di2, $di3, $di4,
		$length, $type, $bindata) = unpack("ClC4C4LCa*", $info);

# convert IPs to dotted quads
my $sip = join('.', $si1, $si2, $si3, $si4);
my $dip = join('.', $di1, $di2, $di3, $di4);

# we can't actually use the length/offset above, because that only
# works for sensor-data (hids-data breaks it).  Just lock the door
# and hope they don't have blasters.
$rem = substr($_, index($_, "\nAR: ") + 1);

# Known packet types:
# 10	HEARTBEAT|EOL|SOF|repeat=
# 67-79	binary packet data (per ddb.html)
# 69,80	WEB:UNAUTH-METHOD
# 129	NETBIOS
# 131	NETBIOS-FAIL
# 254	?
# 255	tcp-stream

# sanity check that we're at the beginning of (one or more) event lines
unless ('AR: ' eq substr($rem,0,4))
{
  warn tell() . ": Invalid data/length/rem\n";
  next;
}

# loop over the remainder looking for event lines.  Be careful; sometimes
# the db file will be missing the 'AX:\n' end-of-record entry, and we'll
# have to punt leftovers (additional/new records) to the top of the loop
my @rem = split(/\n/, $rem);
my @keep;
while (scalar(@rem) and 'AR: ' eq substr($rem[0],0,4))
{
  my $event = shift(@rem);
  unless ($event =~ /^AR: \[([^]]+)\] \(([^)]+)\)/)
  {
    warn "Bad record at " . (tell() - length($_)) . ": '$event'\n";
    next;
  }
  my $evt = $1;
  my $msg = $2;
  my ($prot,$sport,$dport,$flags) = (0,0,0,'');
  my @split_info = split(/,/, $msg);
  foreach my $piece (@split_info) {
    next unless ($piece);
    if ($piece =~ /^dp=(.*)$/)          { $dport = $1;
    } elsif ($piece =~ /^sp=(.*)$/)     { $sport = $1;
    } elsif ($piece =~ /^flags=(.*)$/)  { $flags = $1;
    } elsif ($piece =~ /icmp/)          { $prot = 1;
    } elsif ($piece =~ /^tcp/)          { $prot = 6;
    } elsif ($piece =~ /^udp/)          { $prot = 17;
    } elsif ($piece =~ /^p=(.*)$/)      { $prot = $1;
    }
  }

  # Some events will include the symbolic name of the protocol
  $prot = 1	if ($prot eq 'icmp');
  $prot = 6	if ($prot eq 'tcp');
  $prot = 17	if ($prot eq 'udp');

  # For event types that have packets with headers,
  # extract the IP protocol, source and dest IPs and ports,
  # and verify those against the event metadata.
  my $invalid = 0;
  if ($type > 67 && $type < 80)
  {
    warn tell() . ": Oversized length $length\n" if ($length > 1500);

    my $pkt_proto = ord(substr($bindata, 8, 1));
    my $pkt_src = inet_ntoa(substr($bindata, 11, 4));
    my $pkt_dst = inet_ntoa(substr($bindata, 15, 4));
    my ($pkt_spt, $pkt_dpt) = (0,0);

    # Only TCP and UDP have ports
    if ($pkt_proto == 6 or $pkt_proto == 17)
    {
      $pkt_spt = unpack("n", substr($bindata, 19, 2));
      $pkt_dpt = unpack("n", substr($bindata, 21, 2));
    }

    # Complain if we see packets that don't match their metadata

    if (
        $length > 1500 or
	$sip ne $pkt_src or $dip ne $pkt_dst or
        # some events do not set protocols
        ($evt !~ /^(?:LOKI|WEB:UNAUTH-METHOD|TCP-FLAGS|SYN-DATA.*|FTP-BOUNCE.*|FTP:BINARY|ICMP:PORT-UNREACH|TCP-FRAG-OVERLAY|FTP:IAC-EVADE|(?:LOWTTL|TRACE)-(?:TCP|UDP))$/ and
		$prot ne $pkt_proto) or
        # some events do not set ports
	($evt !~ /^(?:LOCALHOST|SAME-IP|FTP-BOUNCE.*|FRAG-SMALL|RES-BIT|BAD-IP-CKSUM|TCP-FRAG-OVERLAY|WEB:UNAUTH-METHOD)$/ and
	 	($sport ne $pkt_spt or $dport ne $pkt_dpt))
    ) {

      warn "MISMATCH for $evt type $type at " . (tell() - length($_)) . 
	": $prot $sip:$sport -> $dip:$dport  pkt: $pkt_proto $pkt_src:$pkt_spt -> $pkt_dst:$pkt_dpt\n";
      $invalid = 1;
    }
  }

  # Skip this entry if we are trying to match and fail,
  # or if we are discarding matches, and got one.
  my $match = 1;
  $match = 0 if (           $::CheckPackets and not $invalid);
  $match = 0 if ($match and %::Events	and not $::Events{$evt});
  $match = 0 if ($match and %::Sips	and not $::Sips{$sip});
  $match = 0 if ($match and %::Dips	and not $::Dips{$dip});
  $match = 0 if ($match and %::Ips	and not $::Ips{$sip}
					and not $::Ips{$dip});
  $match = 0 if ($match and %::Sensors	and not $::Sensors{$sensor});
  $match = 0 if ($match and %::Sports	and not $::Sports{$sport});
  $match = 0 if ($match and %::Dports	and not $::Dports{$dport});
  $match = 0 if ($match and %::Ports	and not $::Ports{$sport}
					and not $::Ports{$dport});

  $match = 0 if ($match and keys(%::Filters) and not exists $::Filters{$evt});
  if ($match and exists $::Filters{$evt})
  {
    my $hexsip = sprintf("%02x%02x%02x%02x", split(/\./, $sip));
    my $hexdip = sprintf("%02x%02x%02x%02x", split(/\./, $dip));
    foreach my $filter (keys %{$::Filters{$evt}})
    {
      $filter_parsed = $::Filters{$evt}{$filter};
      eval $filter_parsed;
      die "eval failed for '$evt': '$filter_parsed': '$@'" if $@;
      last unless ($match);
    }
  }

  if ($match and %::Body)
  {
    $match = 0;
    foreach my $body_regex (keys %::Body)
    {
      if ($bindata =~ m{$body_regex})
      {
        $match = 1;
        last;
      }
    }
  }

  $match = 1 if ($::FollowSessions and (
	exists $::Sessions{"$sip:$sport:$dip:$dport"} or
	exists $::Sessions{"$dip:$dport:$sip:$sport"}));

  next if ($::Negative == 1 and $match == 1);
  next if ($::Negative == 0 and $match == 0);

  if ($::FollowSessions)
  {
    $::Sessions{"$sip:$sport:$dip:$dport"} = 1;
    $::Sessions{"$dip:$dport:$sip:$sport"} = 1;
  }

  push(@keep, $event);
}

print "$prefix\n" , join("\n", @keep) , "\nAX:\n" if (scalar(@keep));

next unless scalar(@rem);
$_ = join("\n", @rem , "AX:\n");
next LINE;

exit;