sbin/prads.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use warnings;
   5 use FindBin;
   6 use Getopt::Long qw/:config auto_version auto_help/;
   7 use Net::Pcap;
   8 use Data::Dumper;
   9 use DBI;
  10
  11 use constant ETH_TYPE_ARP       => 0x0806;
  12 use constant ARP_OPCODE_REPLY   => 2;
  13
  14 BEGIN {
  15
  16     # list of NetPacket:: modules
  17     my @modules = map { "NetPacket::$_" } qw/Ethernet IP ARP ICMP TCP UDP/;
  18     my $bundle  = 0;
  19
  20     MODULE:
  21     for my $module (@modules) {
  22
  23         # try to use installed version first
  24         eval "use $module";
  25         next MODULE unless($@);
  26
  27         if($ENV{'DEBUG'}) {
  28             warn "$module is not installed. Using bundled version instead\n";
  29         }
  30
  31         # use bundled version instead
  32         local @INC = ("$FindBin::Bin/../lib");
  33         eval "use $module";
  34         die $@ if($@);
  35         $bundle++;
  36     }
  37
  38     if($ENV{'DEBUG'} and $bundle) {
  39         warn "Run this command to install missing modules:\n";
  40         warn "\$ perl -MCPAN -e'install NetPacket'\n";
  41     }
  42 }
  43
  44 =head1 NAME
  45
  46 prads.pl - inspired by passive.sourceforge.net and http://lcamtuf.coredump.cx/p0f.shtml
  47
  48 =head1 VERSION
  49
  50 0.1
  51
  52 =head1 SYNOPSIS
  53
  54  $ prads.pl [options]
  55
  56  OPTIONS:
  57
  58  --dev|-d                : network device (default: eth0)
  59  --config|-c             : path to prads configfile
  60  --service-signatures|-s : path to service-signatures file (default: /etc/prads/tcp-service.sig)
  61  --os-fingerprints|-o    : path to os-fingerprints file (default: /etc/prads/os.fp
  62  --debug                 : enable debug messages 0-255 (default: disabled(0))
  63  --dump                  : Dumps all signatures and fingerprints then exits
  64  --arp                   : Enables ARP discover check
  65  --service               : Enables Service detection
  66  --os                    : Enables OS detection
  67  --db                    : DBI string (default: dbi:SQLite:dbname=prads.db)
  68  --help                  : this help message
  69  --version               : show prads.pl version
  70
  71 =cut
  72
  73 our $VERSION       = 0.1;
  74 our $DEBUG         = 0;
  75 our $DUMP          = 0;
  76 our $ARP           = 0;
  77 our $SERVICE       = 0;
  78 our $OS            = 0;
  79 our $BPF           = q();
  80 our $DATABASE      = q(dbi:SQLite:dbname=prads.db);
  81 our $DB_USERNAME;
  82 our $DB_PASSWORD;
  83
  84
  85 #my $DEVICE         = q(eth0);
  86 my $DEVICE;
  87 my $CONFIG         = q(/etc/prads/prads.conf);
  88 my $S_SIGNATURE_FILE        = q(/etc/prads/tcp-service.sig);
  89 my $OS_SYN_FINGERPRINT_FILE = q(/etc/prads/os.fp);
  90 my $OS_SYNACK_FINGERPRINT_FILE = q(/etc/prads/osa.fp);
  91 my $MAC_SIGNATURE_FILE = q(/etc/prads/mac.sig);
  92 my %pradshosts     = ();
  93 my %ERROR          = (
  94     init_dev => q(Unable to determine network device for monitoring - %s),
  95     lookup_net => q(Unable to look up device information for %s - %s),
  96     create_object => q(Unable to create packet capture on device %s - %s),
  97     compile_object_compile => q(Unable to compile packet capture filter),
  98     compile_object_setfilter => q(Unable to set packet capture filter),
  99     loop => q(Unable to perform packet capture),
 100 );
 101
 102 # extract & load config before parsing rest of commandline
 103     for my $i (0..@ARGV-1){
 104     if($ARGV[$i] =~ /^--?(config|c)$/){
 105         $CONFIG = splice @ARGV, $i, $i+1;
 106         print "Loading config $CONFIG\n";
 107         last; # we've modified @ARGV
 108     }
 109 }
 110 # loads default config if none specified
 111 my $conf = load_config("$CONFIG");
 112 my $C_INIT = $CONFIG;
 113
 114 $DATABASE = $conf->{'db'} if $conf->{'db'};
 115 $DB_USERNAME = $conf->{'db'} if $conf->{'db'};
 116 $DB_PASSWORD = $conf->{'db_username'};
 117 $DEVICE   = $conf->{interface};
 118 $ARP      = $conf->{arp};
 119 $SERVICE  = $conf->{service};
 120 $DEBUG    = $conf->{debug};
 121 $OS       = $conf->{os_fingerprint};
 122 $OS       = $conf->{os_synack_fingerprint};
 123 $OS       = $conf->{os_syn_fingerprint};
 124 $BPF      = $conf->{bpfilter};
 125 $DEBUG ||= 0;
 126
 127 # commandline overrides config
 128 GetOptions(
 129     'config|c=s'             => \$CONFIG,
 130     'dev|d=s'                => \$DEVICE,
 131     'service-signatures|s=s' => \$S_SIGNATURE_FILE,
 132     'os-fingerprints|o=s'    => \$OS_SYN_FINGERPRINT_FILE,
 133     'debug=s'                => \$DEBUG,
 134     'dump'                   => \$DUMP,
 135     'arp'                    => \$ARP,
 136     'service'                => \$SERVICE,
 137     'os'                     => \$OS,
 138     'db'                     => \$DATABASE,
 139     # bpf filter
 140 );
 141 # if 2nd config file specified, load that one too
 142 if ($C_INIT ne $CONFIG){
 143     load_config("$CONFIG");
 144 }
 145 #
 146 #my @array = split(/\s+/, $conf->{array-param});
 147 #my $variable = $conf->{variable};
 148 #$DEBUG    = $conf->{debug};
 149
 150 my $PRADS_HOSTNAME = $conf->{hostname};
 151 $PRADS_HOSTNAME ||= `hostname`;
 152 chomp $PRADS_HOSTNAME;
 153
 154 my $PRADS_START = time;
 155
 156 if ($DUMP) {
 157    print "\n ##### Dumps all signatures and fingerprints then exits ##### \n";
 158
 159    warn "Loading MAC fingerprints\n" if ($DEBUG>0);
 160    my $MAC_SIGS = load_mac($MAC_SIGNATURE_FILE);
 161    print Dumper $MAC_SIGS;
 162
 163    print "\n *** Loading OS fingerprints *** \n\n";
 164    my $OS_SYN_SIGS = load_os_syn_fingerprints($OS_SYN_FINGERPRINT_FILE, $OS_SYNACK_FINGERPRINT_FILE);
 165    print Dumper $OS_SYN_SIGS;
 166
 167    print "\n *** Loading Service signatures *** \n\n";
 168    my @TCP_SERVICE_SIGNATURES = load_signatures($S_SIGNATURE_FILE);
 169    print Dumper @TCP_SERVICE_SIGNATURES;
 170
 171    print "\n *** Loading MTU signatures *** \n\n";
 172    my $MTU_SIGNATURES = load_mtu("/etc/prads/mtu.sig");
 173    print Dumper $MTU_SIGNATURES;
 174
 175    exit 0;
 176 }
 177
 178 warn "Starting prads.pl...\n";
 179
 180 warn "Loading OS fingerprints\n" if ($DEBUG>0);
 181 my $OS_SYN_SIGS = load_os_syn_fingerprints($OS_SYN_FINGERPRINT_FILE, $OS_SYNACK_FINGERPRINT_FILE)
 182               or Getopt::Long::HelpMessage();
 183 my $OS_SYN_DB = {};
 184
 185 warn "Loading MAC fingerprints\n" if ($DEBUG>0);
 186 my $MAC_SIGS = load_mac($MAC_SIGNATURE_FILE);
 187
 188 warn "Loading MTU fingerprints\n" if ($DEBUG>0);
 189 my $MTU_SIGNATURES = load_mtu("/etc/prads/mtu.sig")
 190               or Getopt::Long::HelpMessage();
 191
 192 warn "Initializing device\n" if ($DEBUG>0);
 193 warn "Using $DEVICE\n" if $DEVICE;
 194 $DEVICE = init_dev($DEVICE)
 195           or Getopt::Long::HelpMessage();
 196
 197 warn "Loading TCP Service signatures\n" if ($DEBUG>0);
 198 my @TCP_SERVICE_SIGNATURES = load_signatures($S_SIGNATURE_FILE)
 199                  or Getopt::Long::HelpMessage();
 200
 201 warn "Loading UDP Service signatures\n" if ($DEBUG>0);
 202 # Currently loading the wrong sig file :)
 203 my @UDP_SERVICE_SIGNATURES = load_signatures($S_SIGNATURE_FILE)
 204                  or Getopt::Long::HelpMessage();
 205
 206 warn "Loading persistent database ". $DATABASE ."\n" if ($DEBUG > 0);
 207 $OS_SYN_DB = load_persistent($DATABASE,$DB_USERNAME,$DB_PASSWORD);
 208
 209 warn "Creating object\n" if ($DEBUG>0);
 210 my $PCAP = create_object($DEVICE);
 211
 212 warn "Compiling Berkeley Packet Filter\n" if ($DEBUG>0);
 213 filter_object($PCAP);
 214
 215 warn "Looping over object\n" if ($DEBUG>0);
 216 Net::Pcap::loop($PCAP, -1, \&packets, '') or die $ERROR{'loop'};
 217
 218 warn "Closing device\n" if ($DEBUG>0);
 219 Net::Pcap::close($PCAP);
 220
 221 exit;
 222
 223 =head1 FUNCTIONS
 224
 225 =head2 load_persistent
 226
 227 Load persistent database
 228
 229 =cut
 230
 231 sub load_persistent {
 232     my ($db,$user,$password) = @_;
 233     my $dbh = DBI->connect($db,$user,$password);
 234     my ($sql, $sth);
 235     eval{
 236         no warnings 'all';
 237         my $ms = $SIG{__WARN__};
 238         $SIG{'__WARN__'} = sub { };
 239         #my $sql = "DROP TABLE asset";
 240         #my $sth = $dbh->prepare($sql);
 241         #$sth->execute;
 242         $sql = "CREATE TABLE asset (ip TEXT, service TEXT, time TEXT, fingerprint TEXT,".
 243                      "mac TEXT, os TEXT, details TEXT, link TEXT, distance TEXT, reporting TEXT)";
 244         $sth = $dbh->prepare($sql);
 245        #$dbh->{PrintError} = 0;
 246        #$dbh->{RaiseError} = 0;
 247        #$dbh->{PrintWarn} = 0;
 248        #$dbh->{Warn} = 0;
 249        #$dbh->{Error} = 0;
 250        #
 251         $sth->execute;
 252         $SIG{'__WARN__'} = $ms;
 253     };
 254     if($DEBUG){
 255         #$sql = "DELETE FROM asset WHERE service = 'ARP'";
 256         #$sth = $dbh->prepare($sql) or die "foo $!";
 257         #$sth->execute or die "$!";
 258         $sql = "SELECT * from asset";
 259         $sth = $dbh->prepare($sql) or die "foo $!";
 260         $sth->execute or die "$!";
 261         $sth->dump_results;
 262     }
 263     #$dbh->{'RaiseError'} = 1;
 264     return $dbh;
 265 }
 266
 267
 268
 269 =head2 packets
 270
 271 Callback function for C<Net::Pcap::loop>.
 272
 273  * Strip ethernet encapsulation of captured packet
 274  * pass to protocol handlers
 275 =cut
 276 sub packets {
 277     my ($user_data, $header, $packet) = @_;
 278     $pradshosts{"tstamp"} = time;
 279     warn "Packet received - processing...\n" if($DEBUG>50);
 280
 281     #setup the storage hash.. could also let adding to DB be caller's job
 282     my $ethernet = NetPacket::Ethernet::strip($packet);
 283     my $eth      = NetPacket::Ethernet->decode($packet);
 284
 285     # Check if arp - get mac and register...
 286     if ($ARP == 1 && $eth->{type} == ETH_TYPE_ARP) {
 287         arp_check ($eth, $pradshosts{"tstamp"});
 288         return;
 289     }
 290
 291     unless(NetPacket::IP->decode($ethernet)) {
 292         warn "Not an IP packet..\n" if($DEBUG>50);
 293         warn "Done...\n\n" if($DEBUG>50);
 294         return;
 295     }
 296
 297     # We should now have us an IP packet... good!
 298     my $ip       = NetPacket::IP->decode($ethernet);
 299
 300     # OS finger printing
 301     # Collect necessary info from IP packet; if
 302     my $ttl      = $ip->{'ttl'};
 303     my $ipopts   = $ip->{'options'}; # Not used in p0f
 304     my $len      = $ip->{'len'};     # total length of packet
 305     my $id       = $ip->{'id'};
 306
 307     my $ipflags  = $ip->{'flags'};   # 2=dont fragment/1=more fragments, 0=nothing set
 308     my $df;
 309     if($ipflags == 2){
 310         $df = 1; # Dont fragment
 311     }else{
 312         $df = 0; # Fragment or more fragments
 313     }
 314
 315     # Check if this is a TCP packet
 316     if($ip->{proto} == 6) {
 317       warn "Packet is of type TCP...\n" if($DEBUG>50);
 318       packet_tcp($ip, $ttl, $ipopts, $len, $id, $ipflags, $df);
 319
 320     }elsif ($ip->{proto} == 17) {
 321     # Can one do UDP OS detection !??!
 322        warn "Packet is of type UDP...\n" if($DEBUG>30);
 323        my $udp      = NetPacket::UDP->decode($ip->{'data'});
 324        if ($udp->{'data'} && $SERVICE == 1) {
 325           udp_service_check ($udp->{'data'},$ip->{'src_ip'},$udp->{'src_port'},$pradshosts{"tstamp"});
 326        }
 327
 328     }
 329
 330
 331     warn "Done...\n\n" if($DEBUG>50);
 332     return;
 333 }
 334
 335 =head2 packet_tcp
 336
 337 Parse TCP packet
 338  * Decode contents of TCP/IP packet contained within captured ethernet packet
 339  * Search through the signatures, print dst host, dst port, and ID String.
 340  * Collect pOSf data : ttl,tot,orig_df,op,ocnt,mss,wss,wsc,tstamp,quirks
 341    # Fingerprint entry format:
 342    #
 343    # wwww:ttt:D:ss:OOO...:QQ:OS:Details
 344    #
 345    # wwww     - window size (can be * or %nnn or Sxx or Txx)
 346    #            "Snn" (multiple of MSS) and "Tnn" (multiple of MTU) are allowed.
 347    # ttt      - initial TTL
 348    # D        - don't fragment bit (0 - not set, 1 - set)
 349    # ss       - overall SYN packet size (* has a special meaning)
 350    # OOO      - option value and order specification (see below)
 351    # QQ       - quirks list (see below)
 352    # OS       - OS genre (Linux, Solaris, Windows)
 353    # details  - OS description (2.0.27 on x86, etc)
 354
 355 =cut
 356 sub packet_tcp {
 357     my ($ip, $ttl, $ipopts, $len, $id, $ipflags, $df) = @_;
 358     # Collect necessary info from TCP packet; if
 359     my $tcp      = NetPacket::TCP->decode($ip->{'data'});
 360     my $winsize = $tcp->{'winsize'};
 361     my $tcpflags= $tcp->{'flags'};
 362     my $tcpopts = $tcp->{'options'};
 363     my $seq     = $tcp->{'seqnum'};
 364     my $ack     = $tcp->{'acknum'};
 365     my $urg     = $tcp->{'urg'};
 366     my $data    = $tcp->{'data'};
 367     my $reserved= $tcp->{'reserved'};
 368     my $src_port= $tcp->{'src_port'};
 369     my $dst_port= $tcp->{'dst_port'};
 370
 371     # Check if SYN is set (both SYN and SYN+ACK)
 372     if ($OS == 1 && ($tcpflags & SYN)){
 373         warn "Initial connection... Detecting OS...\n" if($DEBUG>20);
 374         my ($optcnt, $scale, $mss, $sackok, $ts, $optstr, @quirks) = check_tcp_options($tcpopts);
 375
 376         # big packets are packets of size > 100
 377         my $tot = ($len < 100)? $len : 0;
 378
 379         # do we have an all-zero timestamp?
 380         my $t0 = (not defined $ts or $ts != 0)? 0:1;
 381
 382         # parse rest of quirks
 383         push @quirks, check_quirks($id,$ipopts,$urg,$reserved,$ack,$tcpflags,$data);
 384         my $quirkstring = quirks_tostring(@quirks);
 385
 386         my $src_ip = $ip->{'src_ip'};
 387
 388         # debug info
 389         my $packet = "ip:$src_ip size=$len ttl=$ttl, DF=$df, ipflags=$ipflags, winsize=$winsize, tcpflags=$tcpflags, OC:$optcnt, WSC:$scale, MSS:$mss, SO:$sackok,T0:$t0, Q:$quirkstring O: $optstr ($seq/$ack) tstamp=" . $pradshosts{"tstamp"};
 390         print "OS: $packet\n" if($DEBUG > 2);
 391
 392         # We need to guess initial TTL
 393         my $gttl = normalize_ttl($ttl);
 394         my $dist = $gttl - $ttl;
 395
 396         my $wss = normalize_wss($winsize, $mss);
 397         my $fpstring = "$wss:$gttl:$df:$tot:$optstr:$quirkstring";
 398
 399         # TODO: make a list of previously matched OS'es (NAT ips) and
 400         # check on $db->{$ip}->{$fingerprint}
 401
 402         my ($os, $details, @more) = os_find_match(
 403                                 $tot, $optcnt, $t0, $df,\@quirks, $mss, $scale,
 404                                 $winsize, $gttl, $optstr, $src_ip, $fpstring);
 405
 406         # Get link type
 407         my $link = get_mtu_link($mss);
 408
 409         # asset database: want to know the following intel:
 410         # src ip, {OS,DETAILS}, service (port), timestamp, fingerprint
 411         # maybe also add binary IP packet for audit?
 412         if ($tcpflags & ACK){
 413            add_asset('SYNACK', $src_ip, $fpstring, $dist, $link, $os, $details, @more);
 414         }else{
 415            add_asset('SYN', $src_ip, $fpstring, $dist, $link, $os, $details, @more);
 416         }
 417     }
 418     ### SERVICE: DETECTION
 419     ### Can also do src/dst_port
 420     if ($tcp->{'data'} && $SERVICE == 1) {
 421        # Check content(TCP data) against signatures
 422        tcp_service_check ($tcp->{'data'},$ip->{'src_ip'},$tcp->{'src_port'},$pradshosts{"tstamp"});
 423     }
 424
 425 }
 426
 427 =head2 match_opts
 428
 429 Function to match options
 430
 431 =cut
 432
 433 sub match_opts {
 434     my ($o1, $o2) = @_;
 435     my @o1 = split /,/,$o1;
 436     my @o2 = split /,/,$o2;
 437     for(@o1){
 438         print "$_:$o2[0]\n" if $DEBUG & 8;
 439         if(/([MW])(\d*|\*)/){
 440             if(not $o2[0] =~ /$1($2|\*)/){
 441                 print "$o2[0] != $1$2\n" if $DEBUG > 1;
 442                 return 0;
 443             }
 444         }elsif($_ ne $o2[0]){
 445             return 0;
 446         }
 447         shift @o2;
 448     }
 449     return @o2 == 0;
 450 }
 451
 452 =head2 os_find_match
 453
 454 port of p0f find_match()
 455 # WindowSize : InitialTTL : DontFragmentBit : Overall Syn Packet Size : Ordered Options Values : Quirks : OS : Details
 456
 457 returns: ($os, $details, [...])
 458 or undef on fail
 459
 460 for each signature in db:
 461   match packet size (0 means >= PACKET_BIG (=200))
 462   match tcp option count
 463   match zero timestamp
 464   match don't fragment bit (ip->off&0x4000!= 0)
 465   match quirks
 466
 467   check MSS (mod or no)
 468   check WSCALE
 469
 470   -- do complex windowsize checks
 471   -- match options
 472   -- fuzzy match ttls
 473
 474   -- do NAT checks
 475   == dump unknow packet
 476
 477   TODO:
 478     NAT checks, unknown packets, error handling, refactor
 479 =cut
 480
 481 sub os_find_match{
 482 # Port of p0f matching code
 483     my ($tot, $optcnt, $t0, $df, $qq, $mss, $scale, $winsize, $gttl, $optstr, $ip, $fp) = @_;
 484     my @quirks = @$qq;
 485     my $sigs = $OS_SYN_SIGS;
 486     my $guesses = 0;
 487
 488     #warn "Matching $packet\n" if $DEBUG;
 489     #sigs ($ss,$oc,$t0,$df,$qq,$mss,$wsc,$wss,$oo,$ttl)
 490     my $matches = $sigs;
 491     my $j = 0;
 492     my @ec = ('packet size', 'option count', 'zero timestamp', 'don\'t fragment bit');
 493     for($tot, $optcnt, $t0, $df){
 494         if($matches->{$_}){
 495             $matches = $matches->{$_};
 496             #print "REDUCE: $j:$_: " . Dumper($matches). "\n";
 497             $j++;
 498
 499         }else{
 500             print "ERR: $ip [$fp] Packet has no match for $ec[$j]:$_\n";
 501             return;
 502         }
 503     }
 504     # we should have $matches now.
 505     warn "ERR: $ip [$fp] No match in fp db, but should have a match.\n" and return if not $matches;
 506
 507     #print "INFO: p0f tot:oc:t0:frag match: " . Dumper($matches). "\n";
 508     if(not @quirks) {
 509         $matches = $matches->{'.'};
 510         warn "ERR: $ip [$fp] No quirks match.\n" and return if not defined $matches;
 511     }else{
 512         my $i;
 513         for(keys %$matches){
 514             my @qq = split //;
 515             next if @qq != @quirks;
 516             $i = 0;
 517             for(@quirks){
 518                 if(grep /^$_$/,@qq){
 519                     $i++;
 520                 }else{
 521                     last;
 522                 }
 523             }
 524             $matches = $matches->{$_} and last if $i == @quirks;
 525         }
 526         warn "ERR: $ip [$fp]  No quirks match\n" and return if not $i;
 527     }
 528     #print "INFO: p0f quirks match: " . Dumper( $matches). "\n";
 529
 530     # Maximum Segment Size
 531     my @mssmatch = grep {
 532         (/^\%(\d)*$/ and ($mss % $_) == 0) or
 533             (/^(\d)*$/ and $mss eq $_) or
 534             ($_ eq '*')
 535     } keys %$matches;
 536     #print "INFO: p0f mss match: " . Dumper(@mssmatch). "\n";
 537     warn "ERR: $ip [$fp] No mss match in fp db.\n" and return if not @mssmatch;
 538
 539     # WSCALE. There may be multiple simultaneous matches to search beyond this point.
 540     my (@wmatch,@fuzmatch);
 541     for my $s (@mssmatch){
 542         for my $wsc ($scale, '*'){
 543             my $t = $matches->{$s}->{$wsc};
 544             next if not $t;
 545
 546             # WINDOWSIZE
 547             for my $wss (keys %$t){
 548                 #print "INFO: wss:$winsize,$_, " . Dumper($t->{$_}) ."\n";
 549                 if( ($wss =~ /S(\d*)/ and $1*$mss == $winsize) or
 550                     ($wss =~ /M(\d*)/ and $1*($mss+40) == $winsize) or
 551                     ($wss =~ /%(\d*)/ and $winsize % $1 == 0) or
 552                     ($wss eq $winsize) or
 553                     ($wss eq '*')
 554                   ){
 555                     push @wmatch, $t->{$wss};
 556                 }else{
 557                     push @fuzmatch, $t->{$wss};
 558                 }
 559             }
 560         }
 561     }
 562     if(not @wmatch and @fuzmatch){
 563         $guesses++;
 564         @wmatch = @fuzmatch;
 565     }
 566     if(not @wmatch){
 567         print "$pradshosts{tstamp} $ip [$fp] Closest matches: \n" if $DEBUG > 0;
 568         for my $s (@mssmatch){
 569             print Data::Dumper->Dump([$matches->{$s}],["MSS$s"]) if $DEBUG >0;
 570         }
 571
 572         return;
 573     }
 574     #print "INFO: wmatch: " . Dumper(@wmatch) ."\n";
 575
 576     # TCP option sequence
 577     my @omatch;
 578     for my $h (@wmatch){
 579         for(keys %$h){
 580             #print "INFO: omatch:$optstr:$_ " .Dumper($h->{$_}) ."\n";
 581             push @omatch, $h->{$_} and last if match_opts($optstr,$_);
 582         }
 583     }
 584     if(not @omatch){
 585         print "$pradshosts{tstamp} $ip [$fp] Closest matches: \n";
 586         print Data::Dumper->Dump([@wmatch],["WSS"]);
 587         return;
 588     }
 589
 590     my @os;
 591     for(@omatch){
 592         my $match = $_->{$gttl};
 593         if(not $match and $gttl < 255){
 594             # re-normalize ttl, machine may be really distant
 595             # (over ttl/2 hops away)
 596             my $ttl = normalize_ttl($gttl+1);
 597             #print "Re-adjusted ttl from $gttl to $ttl\n" if $ttl != 64;
 598             $match = $_->{$ttl};
 599         }
 600         #print "INFO: omatch: " .Dumper($match) ."\n";
 601         if($match){
 602             for(keys %$match){
 603                 push @os, ($_, $match->{$_});
 604             }
 605         }
 606     }
 607     if(not @os){
 608         print "$pradshosts{tstamp} $ip [$fp] Closest matches: \n" if $DEBUG > 0;
 609         print Data::Dumper->Dump([@omatch],["TTL"]) if $DEBUG > 0;
 610         return;
 611     }
 612
 613     # if we have non-generic matches, filter out generics
 614     my $skip = 0;
 615     my @filtered;
 616
 617     # loop through to check for non-generics
 618     my ($os, $details, @more) = @os;
 619     while($os){
 620         if($os =~ /^[^@]/){
 621             $skip++;
 622             last;
 623         }
 624         ($os, $details, @more) = @more;
 625     }
 626     # filter generics
 627     ($os, $details, @more) = @os;
 628     do{
 629         if(not ($skip and $os =~ /^@/)){
 630             push @filtered, ($os, $details);
 631         }
 632         ($os, $details, @more) = @more;
 633     }while($os);
 634     return @filtered;
 635 }
 636
 637 =head2 check_quirks
 638
 639 # Parse most quirks.
 640 # quirk P (opts past EOL) and T(non-zero 2nd timestamp) are implemented in
 641 # check_tcp_options, where it makes most sense.
 642 # TODO: '!' : broken opts (?)
 643
 644 =cut
 645
 646 sub check_quirks {
 647     my ($id,$ipopts,$urg,$reserved,$ack,$tcpflags,$data) = @_;
 648     my @quirks;
 649
 650     push @quirks, 'Z' if not $id;
 651     push @quirks, 'I' if $ipopts;
 652     push @quirks, 'U' if $urg;
 653     push @quirks, 'X' if $reserved;
 654     push @quirks, 'A' if $ack;
 655     push @quirks, 'F' if $tcpflags & ~(SYN|ACK);
 656     push @quirks, 'D' if $data;
 657     return @quirks;
 658 }
 659
 660 =head2 quirks_tostring
 661  Function to make quirks into a string.
 662 =cut
 663
 664 sub quirks_tostring {
 665     my @quirks = @_;
 666     my $quirkstring = '';
 667     for(@quirks){
 668         $quirkstring .= $_;
 669     }
 670     $quirkstring = '.' if not @quirks;
 671     return $quirkstring;
 672 }
 673
 674
 675 =head2 check_tcp_options
 676
 677 Takes tcp options as input, and returns which args are set.
 678
 679  Input format:
 680  $tcpoptions
 681
 682  Output format.
 683  ($count, $scale, $mss, $sackok, $ts, $optstr, $quirks);
 684
 685 =cut
 686
 687 sub check_tcp_options{
 688     # NetPacket::IP->decode gives us binary opts
 689     # so get the interesting bits here
 690     my ($opts) = @_;
 691     my ($scale, $mss, $sackok, $ts, $t2) = (0,undef,0,undef,0);
 692     print "opts: ". unpack("B*", $opts)."\n" if $DEBUG & 8;
 693     my ($kind, $rest, $size, $data, $count) = (0,0,0,0,0);
 694     my $optstr = '';
 695     my @quirks;
 696     while ($opts){
 697         ($kind, $rest) = unpack("C a*", $opts);
 698         last if not $kind;
 699         $count++;
 700         if($kind == 0){
 701             print "EOL\n" if $DEBUG & 8;
 702             $optstr .= "E,";
 703             # quirk if opts past EOL
 704             push @quirks, 'P' if $rest ne '';
 705             #last;
 706         }elsif($kind == 1){
 707             # NOP
 708             print "NOP\n" if $DEBUG & 8;
 709             $optstr .= "N,";
 710         }else{
 711             ($size, $rest) = unpack("C a*", $rest);
 712             #print "$kind # $size\n";
 713             $size = $size - 2;
 714             #($data, $rest) = unpack "C${size}a", $rest;
 715             if($kind == 2){
 716                 ($mss, $rest) = unpack("n a*", $rest);
 717                 $optstr .= "M$mss,";
 718                 print "$size MSS: $mss\n" if $DEBUG & 8;
 719             }elsif($kind == 3){
 720                 ($scale, $rest) = unpack("C a*", $rest);
 721                 $optstr .= "W$scale,";
 722                 print "WSOPT$size: $scale\n" if $DEBUG & 8;
 723             }elsif($kind == 4){
 724                 # allsacks are OK.
 725                 $optstr .= "S,";
 726                 print "SACKOK\n" if $DEBUG & 8;
 727                 $sackok++;
 728             }elsif($kind == 8){
 729                 # Timestamp.
 730                 my ($c, $t, $tsize) = (0,0,$size);
 731                 while($tsize > 0){
 732                     ($c, $rest) = unpack("C a*", $rest);
 733                     # hack HACK: ts is 64bit and wraps our 32bit perl ints.
 734                     # it's ok tho: we don't care what the value is, as long as it's not 0
 735                     $t <<= 1;
 736                     $t |= $c;
 737                     $tsize--;
 738                 }
 739                 print "TS$size: $t\n" if $DEBUG & 8;
 740                 if($t){
 741                     $optstr .= "T,";
 742                 }else{
 743                     $optstr .= "T0,";
 744                 }
 745                 if(defined $ts and $t){
 746                     # non-zero second timestamp
 747                     push @quirks, 'T';
 748                 }else{
 749                     $ts = $t;
 750                 }
 751             }else{
 752                 # unrecognized
 753                 $optstr .= "?$kind,";
 754                 ($rest) = unpack("x$size a*", $rest);
 755                 print "unknown $kind:$size:" if $DEBUG & 8;
 756             }
 757             print "rest: ". unpack("B*", $rest)."\n" if $DEBUG & 8;
 758         }
 759         $opts = $rest;
 760         last if not defined $opts;
 761     }
 762     chop $optstr;
 763     $optstr = '.' if $optstr eq '';
 764
 765     # MSS may be undefined
 766     $mss = '*' if not $mss;
 767
 768     return ($count, $scale, $mss, $sackok, $ts, $optstr, @quirks);
 769 }
 770
 771
 772 =head2 load_signatures
 773
 774 Loads signatures from file
 775
 776  File format:
 777  <service>,<version info>,<signature>
 778
 779  Example:
 780  www,v/Apache/$1/$2/,Server: Apache\/([\S]+)[\s]+([\S]+)
 781
 782 =cut
 783
 784 sub load_signatures {
 785     my $file = shift;
 786     my %signatures;
 787
 788     open(my $FH, "<", $file) or die "Could not open '$file': $!";
 789
 790     LINE:
 791     while (my $line = readline $FH) {
 792         chomp $line;
 793         $line =~ s/\#.*//;
 794         next LINE unless($line); # empty line
 795         # One should check for a more or less sane signature file.
 796         my($service, $version, $signature) = split /,/, $line, 3;
 797
 798         $version =~ s"^v/"";
 799
 800         $signatures{$signature} = [$service, qq("$version"), qr{$signature}];
 801     }
 802
 803     return map { $signatures{$_} }
 804             sort { length $b <=> length $a }
 805              keys %signatures;
 806 }
 807
 808 =head2 load_mtu
 809
 810 Loads MTU signatures from file
 811
 812  File format:
 813  <MTU>,<info>
 814
 815  Example:
 816  1492,"pppoe (DSL)"
 817
 818 =cut
 819
 820 sub load_mtu {
 821     my $file = shift;
 822     my $signatures = {};
 823
 824     open(my $FH, "<", $file) or die "Could not open '$file': $!";
 825
 826     LINE:
 827     while (my $line = readline $FH) {
 828         chomp $line;
 829         $line =~ s/\#.*//;
 830         next LINE unless($line); # empty line
 831         # One should check for a more or less sane signature file.
 832         my($mtu, $info) = split /,/, $line, 2;
 833         $signatures->{$mtu} = $info;
 834     }
 835     return $signatures;
 836 }
 837
 838 =head2 load_mac
 839
 840 Loads MAC signatures from file
 841
 842  File format:
 843  AB:CD:EE   Vendor   # DETAILS
 844
 845  hash->{'byte'}->{'byte'}->...
 846
 847  on conflicts, if we have two sigs
 848  00-E0-2B          Extreme
 849  00-E0-2B-00-00-01 Extreme-EEP
 850  hash->{00}->{E0}->{2B}->{00}->{00}->{01} = Extreme-EEP
 851  hash->{00}->{E0}->{2B}->{_} = Extreme
 852
 853  if you know of a more efficient way of looking up these things,
 854      look me up and we'll discuss it.
 855
 856 =cut
 857
 858 sub load_mac {
 859     my $file = shift;
 860     my $signatures = {};
 861
 862     open(my $FH, "<", $file) or die "Could not open '$file': $!";
 863
 864     LINE:
 865     while (my $line = readline $FH) {
 866         chomp $line;
 867         $line =~ s/^\s*\#.*//;
 868         next LINE unless($line); # empty line
 869         # One should check for a more or less sane signature file.
 870         my($mac, $info, $details) = split /\s/, $line, 3;
 871         $details ||= '';
 872         $details =~ /\# (.*)$/;
 873         $details = $1;
 874         $details ||= $info;
 875         #print "$mac : $info, $details\n";
 876         my ($prefix, $mask) = split /\//, $mac, 2;
 877         $mask ||= 48;
 878         my ($max, $rem) = ($mask / 8, $mask % 8);
 879         my @bytes = split /[:\.\-]/, $prefix, $max;
 880         if($rem){
 881             if($max == @bytes){
 882                 push(@bytes, sprintf "%s/%d", pop @bytes, $rem);
 883             }else{
 884                 push @bytes, sprintf "00/%d", $rem;
 885             }
 886         }
 887         my $ptr = $signatures;
 888         for my $i (0..@bytes-1){
 889             my $byte = lc $bytes[$i];
 890             $ptr->{$byte} ||= {};
 891             if(not ref $ptr->{$byte}){
 892                 $ptr->{$byte} = { _ => $ptr->{$byte} };
 893             }
 894             if($i == @bytes-1){
 895                 if($ptr->{$byte}->{_}){
 896                     print "XXX: $info $mac crashes with ".Dumper($ptr->{$byte}->{_});
 897                     last;
 898                 }
 899                 $ptr->{$byte}->{_} = [$mac, $info, $details];
 900                 last;
 901             }
 902            $ptr = $ptr->{$byte};
 903         }
 904
 905 =insanity
 906
 907         #print "$mac : $mask\n" if $mask;
 908         #print "$mac\n";
 909         print "!!11!!$mac $prefix\n" if $max != 6;
 910
 911         # handle mac bitmasks (in)sanely
 912         my ($rest, $bits) = (0, 0);
 913         my $ptr = $signatures;
 914         for my $i (0..@bytes-1){
 915             my $byte = lc $bytes[$i];
 916             $bits += 8;
 917             $rest = ($mask? $mask - $bits:0);
 918                     #print Dumper $ptr ;
 919             if((not $mask and $i == @bytes-1) or ($mask and $rest == 0)){
 920                 # ran out of bitmask or bytes
 921                 if(ref $ptr->{$byte}){
 922                     if($ptr->{$byte}->{_}){
 923                         print "ERRXXX: Clash $mac with $ptr->{$byte}->{_}\n";
 924                         last;
 925                     }
 926                     $ptr->{$byte}->{_} = [$mac, $info, $details];
 927                 }else{
 928                     $ptr->{$byte} = [$mac, $info, $details];
 929                 }
 930                 last;
 931             }elsif($rest > 8 or not $mask){
 932                 # still got bytes
 933                 $ptr->{$byte} ||= {};
 934                 if(not ref $ptr->{$byte}){
 935                     $ptr->{$byte} = { _ => $ptr->{$byte} };
 936                 }
 937                 $ptr = $ptr->{$byte};
 938                 #print "$byte;";
 939             }else{
 940                 # $mask and $rest < 8
 941                 if($rest > 0){
 942                     $ptr->{"$byte/$rest"} = [$mac, $info, $details];
 943                 }else{
 944                     print "$byte/XXX/$rest/$mask;";
 945                 }
 946                 last; # because some mac strings don't terminate on the dollar.
 947             }
 948         }
 949         if($mask and $rest > 0){
 950             print "00/ZZZ/$rest";
 951             $ptr->{"00/$rest"} = [$mac, $info, $details];
 952         }
 953         #print " $info, $details\n";
 954
 955         #print Data::Dumper->Dump([$ptr],["*m"]) if $mask;
 956 =cut
 957     }
 958     #print Data::Dumper->Dump([$signatures],["*m"]);
 959     return $signatures;
 960 }
 961
 962 =head2 mac_find_match
 963
 964 Match the MAC address with our vendor prefix hash.
 965
 966 =cut
 967 sub mac_find_match {
 968     my ($mac,$ptr) = @_;
 969     $ptr ||= $MAC_SIGS;
 970
 971     my ($byte, $rest) = split /[:\.-]/, $mac,2;
 972     #print "mac matching: $byte, $rest ";
 973     if(ref $ptr->{$byte}){
 974         #print "recurse\n";
 975         my $match = mac_find_match($rest,$ptr->{$byte}) || $ptr->{$byte}->{_};
 976     }else{
 977         #print "reduce $ptr->{$byte}\n";
 978         return $ptr->{$byte};
 979     }
 980 =insanity
 981             print ":$byte: match\n";
 982             $ptr = $ptr->{$byte};
 983         }else{
 984             # this is end-of-line
 985             my @masks = grep { /([0-9a-fA-F][0-9a-fA-F])\/(\d*)/ } keys %$ptr;
 986             print Data::Dumper->Dump([$ptr ],['*ptr']);
 987             for(@masks){
 988                 print Data::Dumper->Dump([$ptr->{$_} ],['@macmask']);
 989             }
 990             return $ptr; # hopefully (one or more) valid sig.
 991         }
 992     }
 993     print "<: \n";
 994     return $ptr;
 995 =cut
 996 }
 997
 998
 999 =head2 load_os_syn_fingerprints
1000
1001 Loads SYN signatures from file
1002 optimize for lookup matching
1003
1004  if you know of a more efficient way of looking up these things,
1005      look me up and we'll discuss it.
1006
1007 =cut
1008 sub load_os_syn_fingerprints {
1009     my @files = @_;
1010 #    my $file = shift;
1011     # Fingerprint entry format:
1012     # WindowSize : InitialTTL : DontFragmentBit : Overall Syn Packet Size : Ordered Options Values : Quirks : OS : Details
1013     #my $re   = qr{^ ([0-9%*()ST]+) : (\d+) : (\d+) : ([0-9()*]+) : ([^:]+) : ([^\s]+) : ([^:]+) : ([^:]+) }x; # suuure, validate this!
1014     my $rules = {};
1015 for my $file (@files) {
1016     open(my $FH, "<", $file) or die "Could not open '$file': $!";
1017
1018     my $lineno = 0;
1019     while (my $line = readline $FH) {
1020         $lineno++;
1021         chomp $line;
1022         $line =~ s/\#.*//;
1023         next unless($line); # empty line
1024
1025         my @elements = split/:/,$line;
1026         unless(@elements == 8) {
1027             die "Error: Not valid fingerprint format in: '$file'";
1028         }
1029         my ($wss,$ttl,$df,$ss,$oo,$qq,$os,$detail) = @elements;
1030         my $oc = 0;
1031         my $t0 = 0;
1032         my ($mss, $wsc) = ('*','*');
1033         if($oo eq '.'){
1034             $oc = 0;
1035         }else{
1036             my @opt = split /[, ]/, $oo;
1037             $oc = scalar @opt;
1038             for(@opt){
1039                 if(/([MW])([\d%*]*)/){
1040                     if($1 eq 'M'){
1041                         $mss = $2;
1042                     }else{
1043                         $wsc = $2;
1044                     }
1045                 }elsif(/T0/){
1046                     $t0 = 1;
1047                 }
1048             }
1049         }
1050
1051         my($details, $human) = splice @elements, -2;
1052
1053         my $tmp = $rules;
1054         for my $e ($ss,$oc,$t0,$df,$qq,$mss,$wsc,$wss,$oo,$ttl){
1055             $tmp->{$e} ||= {};
1056             $tmp = $tmp->{$e};
1057         }
1058         if($tmp->{$details}){
1059             print "$file:$lineno:Conflicting signature: '$line' overwrites earlier signature '$details:$tmp->{$details}'\n\n" if ($DEBUG);
1060         }
1061         $tmp->{$details} = $human;
1062     }
1063 }# for files loop
1064     return $rules;
1065 }
1066
1067 =head2 init_dev
1068
1069 Use network device passed in program arguments or if no
1070 argument is passed, determine an appropriate network
1071 device for packet sniffing using the
1072 Net::Pcap::lookupdev method
1073
1074 =cut
1075
1076 sub init_dev {
1077     my $dev = shift;
1078     my $err;
1079
1080     unless (defined $dev) {
1081        $dev = Net::Pcap::lookupdev(\$err);
1082        die sprintf $ERROR{'init_dev'}, $err if defined $err;
1083     }
1084
1085     return $dev;
1086 }
1087
1088 =head2 lookup_net
1089
1090 Look up network address information about network
1091 device using Net::Pcap::lookupnet - This also acts as a
1092 check on bogus network device arguments that may be
1093 passed to the program as an argument
1094
1095 =cut
1096
1097 sub lookup_net {
1098     my $dev = shift;
1099     my($err, $address, $netmask);
1100
1101     Net::Pcap::lookupnet(
1102         $dev, \$address, \$netmask, \$err
1103     ) and die sprintf $ERROR{'lookup_net'}, $dev, $err;
1104
1105     warn "lookup_net : $address, $netmask\n" if($DEBUG>0);
1106     return $address, $netmask;
1107 }
1108
1109 =head2 create_object
1110
1111 Create packet capture object on device
1112
1113 =cut
1114
1115 sub create_object {
1116     my $dev = shift;
1117     my($err, $object);
1118     my $promisc = 1;
1119
1120     $object = Net::Pcap::open_live($dev, 1500, $promisc, 0, \$err)
1121               or die sprintf $ERROR{'create_object'}, $dev, $err;
1122     warn "create_object : $dev\n" if($DEBUG>0);
1123     return $object;
1124 }
1125
1126 =head2 filter_object
1127
1128 Compile and set packet filter for packet capture
1129 object - For the capture of TCP packets with the SYN
1130 header flag set directed at the external interface of
1131 the local host, the packet filter of '(dst IP) && (tcp
1132 [13] & 2 != 0)' is used where IP is the IP address of
1133 the external interface of the machine. Here we use 'tcp'
1134 as a default BPF filter.
1135
1136 =cut
1137
1138 sub filter_object {
1139     my $object = shift;
1140 #    my($address, $netmask) = lookup_net($DEVICE);
1141     my $filter;
1142     my $netmask = q(0);
1143 #    my $BPF = q(tcp and src net 192.168.0.0 mask 255.255.255.0);
1144 #    my $BPF = q(ip and src net 87.238.45.0/24);
1145 #   my $BPF = q(src net 0.0.0.0 mask 0.0.0.0 or dst net 0.0.0.0 mask 0.0.0.0);
1146
1147     Net::Pcap::compile(
1148         $object, \$filter, $BPF, 0, $netmask
1149     ) and die $ERROR{'compile_object_compile'};
1150
1151     Net::Pcap::setfilter($object, $filter)
1152         and die $ERROR{'compile_object_setfilter'};
1153     warn "filter_object : $filter\n" if($DEBUG>0);
1154 }
1155
1156 =head2 normalize_wss
1157
1158 Computes WSS respecive of MSS
1159
1160 =cut
1161 sub normalize_wss {
1162     my ($winsize, $mss) = @_;
1163     my $wss = $winsize;
1164     if ($mss =~ /^[+-]?\d+$/) {
1165         if (not $winsize % $mss){
1166             $wss = $winsize / $mss;
1167             $wss = "S$wss";
1168         }elsif(not $winsize % ($mss +40)){
1169             $wss = $winsize / ($mss + 40);
1170             $wss = "T$wss";
1171         }
1172     }
1173     return $wss;
1174 }
1175
1176 =head2 normalize_ttl
1177
1178 Takes a ttl value as input, and guesses intial ttl
1179
1180 =cut
1181
1182 sub normalize_ttl {
1183     my $ttl = shift;
1184     my $gttl = 255;
1185     # Only aiming for 255,128,64,60,32. But some strange ttls like
1186     # 200,30 exist, but are rare
1187     $gttl = 255 if (($ttl >=  128) && (255  > $ttl));
1188     $gttl = 128 if ((128  >=  $ttl) && ($ttl >   64));
1189     $gttl =  64 if (( 64  >=  $ttl) && ($ttl >   32));
1190     $gttl =  32 if (( 32  >=  $ttl));
1191     return $gttl;
1192 }
1193
1194 =head2 tcp_service_check
1195
1196 Takes input: $tcp->{'data'}, $ip->{'src_ip'}, $tcp->{'src_port'}, $pradshosts{"tstamp"}
1197 Prints out service if found.
1198
1199 =cut
1200
1201 sub tcp_service_check {
1202     my ($tcp_data, $src_ip, $src_port,$tstamp) = @_;
1203
1204     # Check content(tcp_data) against signatures
1205     SIGNATURE:
1206     for my $s (@TCP_SERVICE_SIGNATURES) {
1207         my $re = $s->[2];
1208
1209         if($tcp_data =~ /$re/) {
1210             my($vendor, $version, $info) = split m"/", eval $s->[1];
1211             add_asset('SERVICE', $src_ip, $src_port, $vendor, $version, $info);
1212 #            printf("Service: ip=%s port=%i -> \"%s %s %s\" timestamp=%i\n",
1213 #                $src_ip, $src_port,
1214 #                $vendor  || q(),
1215 #                $version || q(),
1216 #                $info    || q(),
1217 #                $tstamp || q()
1218 #            );
1219             last SIGNATURE;
1220         }
1221     }
1222 }
1223
1224 =head2 udp_service_check
1225
1226 Takes input: $udp->{'data'}, $ip->{'src_ip'}, $udp->{'src_port'}, $pradshosts{"tstamp"}
1227 Prints out service if found.
1228
1229 =cut
1230
1231 sub udp_service_check {
1232     my ($udp_data, $src_ip, $src_port,$tstamp) = @_;
1233
1234        # Make UDP asset detection here... PoC CODE at the moment.
1235 ### When ready - call udp_service_check ($udp->{'data'},$ip->{'src_ip'},$udp->{'src_port'},$pradshosts{"tstamp"});
1236        #warn "Detecting UDP asset...\n" if($DEBUG);
1237        if ($src_port == 53){
1238           add_asset('SERVICE', $src_ip, $src_port, "-","-","DNS");
1239 #         printf ("Service: ip=%s port=%i -> \"DNS\" timestamp=%i\n",$src_ip, $src_port, $tstamp);
1240        }
1241        elsif ($src_port == 1194){
1242           add_asset('SERVICE', $src_ip, $src_port, "OpenVPN","-","-");
1243 #         printf ("Service: ip=%s port=%i -> \"OpenVPN\" timestamp=%i\n",$src_ip, $src_port, $tstamp);
1244        }
1245        else {
1246         warn "UDP ASSET DETECTION IS NOT IMPLEMENTED YET...\n" if($DEBUG>20);
1247        }
1248
1249 #    # Check content(udp_data) against signatures
1250 #    SIGNATURE:
1251 #    for my $s (@UDP_SERVICE_SIGNATURES) {
1252 #        my $re = $s->[2];
1253 #
1254 #        if($udp_data =~ /$re/) {
1255 #            my($vendor, $version, $info) = split m"/", eval $s->[1];
1256 #            printf("SERVICE: ip=%s port=%i -> \"%s %s %s\" timestamp=%i\n",
1257 #                $src_ip, $src_port,
1258 #                $vendor  || q(),
1259 #                $version || q(),
1260 #                $info    || q(),
1261 #                $tstamp || q()
1262 #            );
1263 #            last SIGNATURE;
1264 #        }
1265 #    }
1266 }
1267
1268 =head2 arp_check
1269
1270 Takes 'NetPacket::Ethernet->decode($packet)' and timestamp as input and prints out arp asset.
1271
1272 =cut
1273
1274 sub arp_check {
1275     my ($eth,$tstamp) = @_;
1276
1277     my $arp = NetPacket::ARP->decode($eth->{data}, $eth);
1278     my $aip = $arp->{spa};
1279     my $h1 = hex(substr( $aip,0,2));
1280     my $h2 = hex(substr( $aip,2,2));
1281     my $h3 = hex(substr( $aip,4,2));
1282     my $h4 = hex(substr( $aip,6,2));
1283     my $ip = "$h1.$h2.$h3.$h4";
1284
1285     my $ash = $arp->{sha};
1286     # more human readable
1287     # join(':', split(/([0-9a-fA-F][0-9a-fA-F])/, $ash);
1288     my $mac =
1289         substr($ash,0,2) .':'.
1290         substr($ash,2,2) .':'.
1291         substr($ash,4,2) .':'.
1292         substr($ash,6,2) .':'.
1293         substr($ash,8,2) .':'.
1294         substr($ash,10,2);
1295     add_asset('ARP', $mac, $ip, @{mac_find_match($mac)});
1296 }
1297
1298 =head2 get_mtu_link
1299
1300  Takes MSS as input, and returns a guessed Link for that MTU.
1301
1302 =cut
1303
1304 sub get_mtu_link {
1305     my $mss = shift;
1306     my $link = "UNKNOWN";
1307 #   if ($mss =~ m/^[0-9]+$/) {
1308     if ($mss =~ /^[+-]?\d+$/) {
1309        my $mtu = $mss + 40;
1310        if (my $link = $MTU_SIGNATURES->{ $mtu }) {return $link}
1311     }
1312     return $link;
1313 }
1314
1315 =head2 load_config
1316
1317  Reads the configuration file and loads variables.
1318  Takes the config file as input, and returns a hash of config options.
1319
1320 =cut
1321
1322 sub load_config {
1323     my $file = shift;
1324     my $config = {};
1325     if(not -r "$file"){
1326         warn "Config '$file' not readable\n";
1327         return $config;
1328     }
1329     open(my $FH, "<",$file) or die "Could not open '$file': $!\n";
1330     while (my $line = <$FH>) {
1331         chomp($line);
1332         $line =~ s/\#.*//;
1333         next unless($line); # empty line
1334         if (my ($key, $value) = ($line =~ m/(\w+)\s*=\s*(.*)$/)) {
1335 #        my ($key, $value) = ($line =~ m/(\w+)\s*=\s*(.*)$/);
1336            warn  "$key:$value\n";
1337            $config->{$key} = $value;
1338         }else {
1339           die "Error: Not valid configfile format in: '$file'";
1340         }
1341     }
1342     close $FH;
1343     return $config;
1344 }
1345
1346 =head2 add_db
1347
1348 Add an asset record to the asset table;
1349
1350 =cut
1351 {
1352    my $table;
1353    my $h_select;
1354    my $h_update;
1355    my $h_insert;
1356 sub add_db {
1357     my $db = $OS_SYN_DB;
1358     my ($dbh, $ip, $service, $time, $fp, $mac, $os, $details, $link, $dist, $host) = @_;
1359     $table = 'asset';
1360     my $sql = "SELECT ip,fingerprint,time FROM $table WHERE ip = ? AND fingerprint = ?";
1361     #print "$sql,$ip,$service,$time,$fp,$mac,$os,$details,$link,$dist,$host\n" if $service eq 'ARP';
1362
1363     $h_select = $db->prepare_cached($sql) or die "Failed:$!" if not $h_select;
1364     $h_select->execute($ip,$fp);
1365     my ($o_ip, $o_fp, $o_time) = $h_select->fetchrow_array();
1366     if($o_time){
1367         if($o_time < $PRADS_START){
1368             printf "%11d [%-10s] ip:%16s - %s - %s [%s] distance:%d link:%s %s\n",
1369                    $o_time, $service, $ip, $os, $details, $fp, $dist, $link, '[OLD]';
1370             #print "$o_time [$service] ip:$ip - $os - $details [$fp] distance:$dist link:$link [OLD]\n";
1371         }
1372
1373        $h_update = $db->prepare_cached("UPDATE $table SET time=? WHERE ip=? AND fingerprint=?") or die "$!" if not $h_update;
1374        $h_update->execute($time,$ip,$fp);
1375     }else{
1376        $h_insert = $db->prepare_cached(
1377          "INSERT INTO $table ".
1378          "(ip, service, time, fingerprint, mac, os, details,".
1379           "link, distance, reporting)".
1380          "VALUES (?,?,?,?,?,?,?,?,?,?)") if not $h_insert;
1381          #('$ip', '$service', '$time', '$fp', '$mac', '$os', '$details', '$link', '$dist', '$host')") if not $h_insert;
1382        $h_insert->execute($ip,$service,$time,$fp,$mac,$os,$details,$link,$dist,$host);
1383
1384        printf "%11d [%-10s] ip:%16s - %s - %s [%s] distance:%d link:%s %s\n",
1385               $time, $service, $ip, $os, $details, $fp, $dist, $link, '';
1386     }
1387 }
1388 }
1389
1390 =head2 add_asset
1391
1392 Takes input: type, type-specific args, ...
1393 Adds the asset to the internal list of assets, or if it exists, just updates the timestamp.
1394
1395 =cut
1396
1397 sub add_asset {
1398     my $db = $OS_SYN_DB;
1399     my ($type, @rest) = @_;
1400
1401     if($type eq 'SYN'){
1402         my ($src_ip, $fingerprint, $dist, $link, $os, $details, @more) = @rest;
1403
1404         if(not $os){
1405             $os = 'UNKNOWN';
1406             $details = 'UNKNOWN';
1407         }
1408         add_db($db, $src_ip, $type, $pradshosts{'tstamp'}, $fingerprint, '', $os, $details, $link, $dist, $PRADS_HOSTNAME);
1409     }elsif($type eq 'SYNACK'){
1410         my ($src_ip, $fingerprint, $dist, $link, $os, $details, @more) = @rest;
1411
1412         if(not $os){
1413             $os = 'UNKNOWN';
1414             $details = 'UNKNOWN';
1415         }
1416         add_db($db, $src_ip, $type, $pradshosts{'tstamp'}, $fingerprint, '', $os, $details, $link, $dist, $PRADS_HOSTNAME);
1417     }elsif($type eq 'ARP'){
1418         my ($mac, $ip, $prefix, $vendor, $details, @more) = @rest;
1419
1420         add_db($db, $ip, $type, $pradshosts{'tstamp'}, $prefix, $mac, $vendor, $details, 'ethernet', 1, $PRADS_HOSTNAME);
1421     }
1422
1423 #   Service: ip=87.238.47.67 port=631 -> "CUPS 1.2 " timestamp=1242033096
1424 #   add_asset('SERVICE', $ip, $port, $vendor, $version, $info, @more);
1425     elsif($type eq 'SERVICE'){
1426         my ($ip, $port, $vendor, $version, $info, @more) = @rest;
1427
1428         add_db($db, $ip, $type, $pradshosts{'tstamp'}, "$ip:$port", '', $vendor, "$info; $version","SERVICE", 1, $PRADS_HOSTNAME);
1429     }
1430 }
1431
1432 =head1 AUTHOR
1433
1434 Edward Fjellskål
1435
1436 Jan Henning Thorsen
1437
1438 Kacper Wysocki
1439
1440 =head1 COPYRIGHT
1441
1442 This library is free software, you can redistribute it and/or modify
1443 it under the same terms as Perl itself.
1444
1445 =cut