LaBrea::Tarpit - Utilities and web displays for

  LaBrea::Tarpit - Utilities and web displays for 
  Tom Liston's LaBrea scanner/worm disruptor

  See: http://sourceforge.net/projects/labrea/

  use LaBrea::Tarpit qw( [exportable functions] );
  or
  require LaBrea::Tarpit;

  daemon(%hash or \%hash);

  $bandwidth = bandwidth(\%tarpit);

  $midnight = midnight($epoch_time,$tz);

  $timezone = timezone($now);

  $sec = $tz2_sec($tz);

  $time_string = their_date($gmtime,$tz);

  $rv = restore_tarpit(\%tarpit,path2cache_file);

  $rv = log2_mem(\%tarpit,log_line,is_daemon,port_intvls,DShield);

  $rv = process_log(\%tarpit,path2log_file,is_daemon,port_intvls);

  $rv = cull_threads(\%tarpit,timeout,scanners,port_intvls,DShield);

  $rv = write_cache_file(\%tarpit,path2cache_file,umask,flag);

        prep_report(\%tarpit,\%hash);

  $rv = find_old_threads(\%tarpit,\%report,$age);

 Signals:

  HUP		cull then write new cache file
  TERM		cull, write cache, exit

  Killing the daemon with SIG_KILL (-9) will NOT write
  a new cache file and will leave LaBrea running.
  YOU SHOULD NOT DO THIS

  Usage:
	connect to TCP port 8686
	send "standard" (endline)
	  or
	send "active" (endline)
	  or
	send "short" (endline)
	  or
	send "config" (endline)

        Net::Whois::IP version 0.35     
	Net::Netmask version 1.8 or higher
        LaBrea version 2.4b3 or higher

  None by default.

	recurse_hash2txt
	daemon
	bandwidth
	midnight
	timezone
	tz2_sec
	their_date
	restore_tarpit
	log2_mem
	process_log
	cull_threads
	write_cache_file
	prep_report
	find_old_threads
	array2_tarpit

#!/usr/bin/perl
package LaBrea::Tarpit;
#
# 2-5-05, michael@bizsystems.com
#
BEGIN { $SIG{'__WARN__'} = sub { warn $_[0] if $DOWARN }}
$__PACKAGE__::DOWARN = 1;
use strict;
#use diagnostics;
use vars qw($VERSION @ISA @EXPORT_OK);

$VERSION = do { my @r = (q$Revision: 1.36 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

use Fcntl qw(:DEFAULT :flock);
use AutoLoader 'AUTOLOAD';
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(
	recurse_hash2txt
	daemon
	bandwidth
	midnight
	timezone
	tz2_sec
	their_date
	restore_tarpit
	log2_mem
	process_log
	cull_threads
	write_cache_file
	prep_report
	find_old_threads
	array2_tarpit
);

use constant defaults => {	# seconds
	'cull'		=> 600, # drop threads older than this
	'min_age'	=> 15,	# don't cull for at least
	'auto_cull'	=> 900,	# cull at least every
	's_timeout'	=> 0.1,	# select timeout
	'sock_timeout'	=> 180,	# give up on socket response
};
use constant mon => {
	qw(jan 0 feb 1 mar 2 apr 3 may 4 jun 5 jul 6 aug 7 sep 8 oct 9 nov 10 dec 11)
};

# memory records are kept in the form:
#
# %tarpit			# time is kept in seconds since epoch
#	{bw}	-> bandwidth	# bytes per second
#
#	{tz}	-> timezone	# i.e. text string = -800	
#
#	{now"	-> epoch time	# only used when writing cache, 
#				# not current otherwise
#   active threads
#	{at}	-> {srcIP_1}	-> {sp1} -> {dip} -> destination IP
#		     .	      (src_port1)   {dp}  -> destination port
#		     .	      .		    {pst} -> protocol type (0,6=tcp)
#						for tcp = persistent [true/false]
#		     .	      .		    {ct}  -> capture time
#		     .	      .		    {lc}  -> last contact time
#		     .        .
#		     .		-> {sp2} -> {dip} -> destination IP
#		     .	      (src_port2)   {dp}  -> destination port
#		     .			    {pst} -> protocol type (0,6=tcp)
#						for tcp =  persistent [true/false]
#		     .			    {ct}  -> capture time
#		     .			    {lc}  -> last contact time
#		     .
#		   {srcIP_2}	-> etc...
#   dead threads
#	{dt}	-> {srcIP}	-> {dp}  -> last destination port
#				   {lc}  -> last contact time
#		     .
#   port stats
#	{ph}	-> {timea}	-> {port num.x}	  -> count
#		     .		-> {port num.y}   -> count
#		     .		-> {port num.z}   -> count
#		   (timeb}	-> etc...
#
#	{pt}	-> collection_interval

# input:	txt out pointer, pointer to hash, keys so far, dump | debug
# 		if the dod flag is 0, this is normal dump mode
#		else it's the fancy debug mode
sub recurse_hash2txt {
  my ($txp, $p, $ksf,$dod) = @_;
  foreach my $key (sort keys %{$p}) {
    my $keysnow = $ksf;
    $keysnow .= ($dod) ? qq|->{$key}|
	: ($ksf) 
		? ':'. $key
		: $key;
    if (ref $p->{$key}) {
      &recurse_hash2txt($txp,$p->{$key},$keysnow,$dod);
    } else {
      $keysnow .= ($dod) ? ' = ' : ':';
      $keysnow .= ($p->{$key} || 0) . "\n";
      $$txp .= $keysnow;
    }
  }
}

sub lbd_open {
  my($LaBrea,$DEBUG) = @_;
  local *LABREA;
  $LaBrea =~ /^([^\s]+)/;		# bare path to LaBrea
  qx/$1 -V 2>&1/ =~ /(\d+\.[^\s]+)/;	# get version
  my $version = $1;			# save version
# open LaBrea daemon
  my $kid = open(LABREA,$LaBrea .' |');
  die "Can't open $LaBrea: $!" unless $kid;
  unless ($DEBUG) {
    open STDERR, '>&STDOUT'		or die "Can't dup stdout: $!";
  }
  $0 = __PACKAGE__.' '.$0;		# set ps(1) name to package name
  return(*LABREA,$version,$kid);
}

sub lbd_close {
  my($LBfh,$kid) = @_;
  kill 15, $kid;				# kill LaBrea
  close $LBfh;
}

# autoload everything to keep daemon small
sub daemon;
sub bandwidth;
sub midnight;
sub timezone;
sub restore_tarpit;
sub log2_mem;
sub process_log;
sub cull_threads;
sub write_cache_file;
sub prep_report;
sub find_old_threads;
sub array2_tarpit;

# helper subroutines
#sub _cullnsquish;
sub _check4cull;
sub _init_pt;
sub _add_array;
sub _cache2txt;
sub _ex_append;
sub _get_config;
sub DESTROY {};

1;
__END__

# 'DEBUG'	=> undef,		turn on STDERR in daemon

# helper routine
#
# check for time to cull cache of old threads
# this does not need to be done often because 
# LaBrea holds most indefinetly unless the black 
# hat guys give up. Call with a small wait time 
# when dumping the cache for use in a web page
# 
# input:	time between culls
#
# returns:	true if cull reduces thread count, else false
#
sub _check4cull {
  my ($tp,$ttcp,$wait_time,$cull,$scrs,$ph,$ds) = @_;
  my $now = $tp->{now} = time;
  if ( $now > $$ttcp + $wait_time ) {
    $$ttcp = $now;		# reset wait time
    return &cull_threads($tp, $cull, $scrs, $ph, $ds);
  }
  0;
}

# check as above and if there is a tarpit cull,
# collapse the tarpit hash to conserve memory
# 1) write out the hash to disk
# 2) set the tarpit hash to an anon empty array
# 3) reload the tarpit from the disk
#
# returns:	true if cull, else false
#		fails silently if there is no cache file

#sub _cullnsquish {
#  my ($tp,$ttcp,$wait_time,$cull,$scrs,$ph,$ds,$pt,$cache_file,$umask,$version) = @_;
#  my $rv;
#  if ($rv = &_check4cull($tp,$ttcp,$wait_time,$cull,$scrs,$ph,$ds)) {	# cull every few minutes
#    my $cache_txt = &write_cache_file($tp,$cache_file,$umask,1);	# write cache file and return cache text
#    %$tp = ();								# collapse tarpit hash;
#    my @lines = split("\n",$cache_txt);
#    &array2_tarpit($tp,\@lines);  # returns true
#    $tp->{LaBrea} = $version;						# set version number
#    $tp->{pt} = $pt || 86400;						# default data collection is one day
#  }
#  $rv;
#}
  
# input:	file name, mark text
# returns:	lines of file with ' mark text\n' appended
#
sub _get_config {
  my ($f,$mark) = @_;
  $mark = ' ' . $mark if $mark;
  local *F;
  return '' unless open(F,$f);
  @_ = (<F>);		# slurp lines
  close F;
  chop @_;
  my $rv = join("$mark\n",@_);
  $rv .= "$mark\n" if $rv;
};

# make daemon
#
# KILL with signal TERM, -15
# dump cache with SIG_HUP
#
# input:	%hash or \%hash above
#
sub daemon {
  my $pid;
  $_ = ( ref $_[0] ) ? $_[0] : {@_};
  my ($LaBrea,$config,$pid_file,$max_kids,$d_port,$d_host,$allowed,$cache_file,$umask,$cull,$scrs,   $ph,        $pt,       $ds,   $DEBUG) = @{$_}{
    qw(LaBrea  config  pid           kids  d_port  d_host  allowed  cache       umask  cull scanners port_intvls port_timer DShield DEBUG)};

# fork and test
  unless ( $pid = fork ) {
# clean up for proper daemon operation
    chdir '/';			# allow root dismount
    open STDIN, '/dev/null'	or die "Can't read /dev/null: $!";
    open STDOUT, '>/dev/null'	or die "Can't write to /dev/null: $!";
    unless ( $pid = fork ) {
      local(*SERVER,*CLIENT);

      require LaBrea::NetIO;
      import LaBrea::NetIO qw(
	open_listen_sock
	reap_kids
	set_so_linger
	sockaddr_in
	inet_ntoa
      );

# open server port

      die $_ if ($_ = open_listen_sock(*SERVER,$d_host,$d_port));
      my $flags = fcntl(SERVER,F_GETFL,0)	|| die "can't get socket flags";
      fcntl(SERVER,F_SETFL,$flags | O_NONBLOCK)	|| die "can't set socket non-blocking";

      require POSIX;
      my $tarpit = {};
      &POSIX::setsid()	or die "Can't start new session: $!";
      my($LBfh,$version,$kid) = lbd_open($LaBrea,$DEBUG);
      $umask = 033 unless $umask;
      $cull = defaults->{cull} unless $cull;
      $ph = 0 unless $ph;
      my $time2cull = time + $cull;	# first cull must wait

##### define signal services within this scope

      my $run = 1;
      my $hup = 0;

$__PACKAGE__::DOWARN = 0;		# quite warnings about 
      my $quit = sub {			# portability of $run, $hup
	$run = 0;
      };
      my $dohup = sub {
	$hup = 1;
      };
$__PACKAGE__::DOWARN = 1;

#      local $SIG{HUP} = $dohup;
#      local $SIG{INT} = $dohup;
#      local $SIG{TERM} = $quit;

      local $SIG{HUP} = sub { $hup = 1; };
      local $SIG{INT} = sub { $hup = 1; };
      local $SIG{TERM} = sub { $run = 0; };
      local $SIG{PIPE} = 'IGNORE';

      &restore_tarpit($tarpit,$cache_file) if -e $cache_file;
      $tarpit->{LaBrea} = $version;	# set version number
      $tarpit->{pt} = $pt || 86400;	# default data collection is one day

# prepare daemon loop
      my $WNOHANG = &POSIX::WNOHANG; 
      my $rin = '';
      vec($rin,fileno($LBfh),1) = 1;
      my $timeout = defaults->{s_timeout};
      my ($rout,$paddr,%kids);

      my @valid_clients;
      foreach(split(',', $allowed)) {
	(undef,undef,undef,undef,@_) = gethostbyname($_);
	push @valid_clients,@_;
      }

      $max_kids = 5 unless $max_kids;
      my $kids = 0;		# number of kids alive
      while($run) {
# accept for SERVER is not set for 'select', find it with the POLL
	my $ready = select($rout=$rin,undef,undef,$timeout);
	if ( $ready > 0 ) {
	  $_ = <$LBfh>;	# blocks, but doesn't matter here
	  last unless $_;	# Oops, LaBrea must have died, EXIT
	  &log2_mem($tarpit,$_,1,$ph,$ds);
#	  &_cullnsquish($tarpit,\$time2cull,defaults->{auto_cull},$cull,$scrs,$ph,$ds,$pt,$cache_file,$umask,$version);
	  if (&_check4cull($tarpit,\$time2cull,defaults->{auto_cull},$cull,$scrs,$ph,$ds)) {	# cull every few minutes
		;
# revert cull operation to previous behavior
# the code below does not seem to improve memory usage
#	    my $cache_txt = &write_cache_file($tarpit,$cache_file,$umask,1);	# write cache file and return cache text
#	    $tarpit = {};							# collapse tarpit hash;
#	    my @lines = split("\n",$cache_txt);
#	    &array2_tarpit($tarpit,\@lines);					# returns true
#	    $tarpit->{LaBrea} = $version;					# set version number
#	    $tarpit->{pt} = $pt || 86400;					# default data collection is one day
	  }
	} 
	elsif ( $hup ) {
#	  &write_cache_file($tarpit,$cache_file,$umask,1) unless
#	    &_cullnsquish($tarpit,\$time2cull,defaults->{min_age},$cull,$scrs,$ph,$ds,$pt,$cache_file,$umask,$version);	# cull immediate
	  &_check4cull($tarpit,\$time2cull,defaults->{auto_cull},$cull,$scrs,$ph,$ds);	# cull immediate
	  &write_cache_file($tarpit,$cache_file,$umask,1);				# and write cache file
	  $hup = 0;
	}
	elsif ( $kids < $max_kids && ($paddr = accept(CLIENT,SERVER)) ) {	# client has connected
	  if ($pid = fork) {
	    close CLIENT; 			# close if parent
	    $kids{$pid} = ++$kids if $pid;	# bump kid count, val is not used
	  } else {				# CHILD, service request
	    close SERVER;

########### CHILD PROCESS #################

	    local $SIG{ALRM} = sub { die "child connect timeout" };

	    my $iaddr = (sockaddr_in($paddr))[1];
	    unless ( ( ! @valid_clients || 			# allow all
			 grep($_ == $iaddr,@valid_clients)) && 	# or small number
			set_so_linger(*CLIENT,30)) {		# linger 30 seconds to deliver stuff
	      close CLIENT;
	      exit 0;			# exit silently if not allowed or can't set linger
	    }
	    
	    &_check4cull($tarpit,\$time2cull,defaults->{min_age},$cull,$scrs,$ph,$ds);	# cull immediate

	    eval {
	      my $cache_txt = '';
	      alarm defaults->{sock_timeout};
	      my $request = readline *CLIENT;
	      if ( $request =~ /^standard/ ) {			# full tarpit contents
		$request = $tarpit;
	      }
	      elsif ( $request =~ /^short/ ) {			# short totals only
		$request = { 'Tarpit'	=> $VERSION };		# version in format for other end
		prep_report($tarpit,$request);
	      }
	      elsif ( $request =~ /^active/ ) {		# only active threads
		$request = { 'at' => $tarpit->{at} };
	      }
	      elsif ( $request =~ /^config/ ) {		# return config info
		if ( $config ) {
		  if (ref $config) {	# if it is array format
		    @_ = @{$config};
		  } else {
		    @_ = ($config);
		  }
		  my ($hard_ex,$exclude,$new_config);
		  if ( $_[0] =~ /Exclude/ ) {		# old style
		    if ( $_[0] =~ /Hard/ ) {
		      $cache_txt .= &_get_config($_[0],'hardexclude');
		    } else {
		      $cache_txt .= &_get_config($_[0],'exclude');
		    }
		    if ( @_ > 1 ) {			# if second argument
		      if ( $_[1] =~ /Hard/ ) {
			$cache_txt .= &_get_config($_[1],'hardexclude');
		      } elsif ( $_[1] =~ /Exclude/ ) {
			$cache_txt .= &_get_config($_[1],'exclude');
		      }
		    }
		  } elsif ( $_[0] =~  /Config/ ||
				      /LaBrea\.cfg/ ) {	# new style, config true
		    
		    $cache_txt .= &_get_config($_[0],'');
		  }
		} # end config file info
		$cache_txt = "none\n" unless $cache_txt;

	      } else {		# unknown

		alarm 0;
		close CLIENT;
		exit 0;
	      }

	      &_cache2txt(\$cache_txt,$request,'daemon') unless $cache_txt;
	      my $len = length($cache_txt);
	      my $off = 0;
	      my $win = '';
	      my ($wout,$eout);
	      vec($win,fileno(CLIENT),1) = 1;
	      my $ein = $win;
	      while ($len) {
		$ready = select(undef,$wout=$win,undef,defaults->{pipe_timeout});	# block until write or error
		last unless $ready;		# punt if timeout
		my $wrote = syswrite(CLIENT,$cache_txt,$len,$off);
		last unless defined $wrote;	# only errors
#	      if ( ! defined $wrote ) {
#		next if $! == EAGAIN;		# would block
#	      }
		$off += $wrote;
		$len -= $wrote;
	      }
	    };	
	    alarm 0;
	    close CLIENT;
	    exit 0;				# child dies
	  }
########### END CHILD #################
	}
	else {
	  $kids = reap_kids(\%kids);		# dispose of dead kids, return remaining number
	}
      }
      lbd_close($LBfh,$kid);
      &_check4cull($tarpit,\$time2cull,defaults->{min_age},$cull,$scrs,$ph,$ds);	# cull threads
      &write_cache_file($tarpit,$cache_file,$umask,1);
      foreach $kid ( keys %kids ) {
	kill 15, $kid;				# kill remaining children
      }
      unlink $pid_file;
      exit 0;
    }
    exit 1 unless open(PID,'>'.$pid_file);
    print PID $pid, "\n";
    close PID;
    exit 0;
  }
  waitpid($pid,0);
}

# return the current bandwidth
#
# input:	\%tarpit
# return:	bandwidth
#
sub bandwidth {
  my ($tp) = @_;
  return $tp->{bw} || 0;
}

sub midnight {
  my ($et,$tz) = @_;
  $tz = &timezone($et) unless $tz;
  my $mn= $et - tz2_sec($tz) - ($et%86400);
  if ($mn > $et) {
    $mn -= 86400;
  } elsif ($et - $mn >= 86400) {
  $mn += 86400;
  }
  $mn;
}

sub tz2_sec {
  my ($tz) = @_;
  my $tza = abs $tz;
  my $min = $tza % 100;
  my $hr = $tza - $min;
  my $sec = ($hr * 36) + $min * 60;
  $sec = -$sec if $tz < 0;
  $sec;
}
  

sub their_date {
  my ($time,$tz) = @_;
  return gmtime($time + tz2_sec($tz)) . ' ' . $tz;
}

sub timezone {
  my $t = $_[0] || time;
  my $tt = $t;
  my (@lt) = localtime($t);
  my (@gt) = gmtime($t);
  my $tzmin = ($gt[1] - $lt[1]) + ($gt[2] - $lt[2]) * 60;
  if($lt[5] > $gt[5]) {
    $tzmin -= 1440;
  }
  elsif($gt[5] > $lt[5]) {
    $tzmin += 1440;
  }
  else {
    $tzmin += ($gt[7] - $lt[7]) * 1440;
  }
  $tzmin += 60 if $lt[8];
  my $time = $t + $tzmin * 60;
  my @test = localtime($time + ($tt - $t));
  $tzmin -= 60 if $test[2] != $gt[2];
  my $tz = abs $tzmin;
  my $min = $tz % 60;
  my $hr = ($tz - $min) / 60;
  $tz = ($tzmin < 0 )
        ? '+' : '-';
  $tz .= sprintf("%02d%02d",$hr,$min);
}

# build hash from database file
#
# input:	\%tarpit, $db_file_path_name
# return:	true or false if fail

sub restore_tarpit {
  my ($tp,$dbf) = @_;
  return undef unless open(DB,$dbf);
  my @lines = (<DB>);
  close DB;
  chop @lines;		# no new-lines
  &array2_tarpit($tp,\@lines);	# returns true
}

sub array2_tarpit {
  my ($tp,$ary) = @_;
  foreach(@$ary) {
    next unless $_ =~ /^[a-zA-Z]/;	# must start with alpha tag
    my @arg = split(':', $_);
    next unless @arg > 1;		# must be at least two items
    my $inst = '$tp';
    foreach(0..$#arg -1) {
      $inst .= '->{$arg[' . $_ . ']}';
    }
    $inst .= ' = $arg[' . $#arg . '];';
    eval $inst;
  }
  1;    # return true
}

# update the tarpit cache from log line, see comments below for format
#
# input:	\%tarpit, log_line, is_daemon, port_intvls, DShield_flag
#
#
sub log2_mem {
  my ($tp,$line,$id,$ph,$ds) = @_;
  return undef if (!$id && $line !~ /LaBrea:/);
# valid Labrea log line to parse
  if ( $line =~ /.+bw:\s+(\d+)\s+/ ) {	# if bandwidth line
    $tp->{bw} = $1 || 0;
    return 1;
  }
  # extract time / date
  my $time;
  if ( $line =~ /^(\d+)\s+/ ) {
    $time = $1;
  } else {		# complex form
    require Time::Local;
    return undef unless $line =~ /(.+)\s+(\d+):(\d+):(\d+)\s+(\w+)\s+/;
    @_ = split(/\s+/,$1);
    my $day = pop @_;
    my $mon = pop @_;
    $mon = mon->{"\L$mon"};
    my ($hr,$min,$sec,$yr) = ($2,$3,$4,$5);
    if ($yr =~ /[^\d]/) {
      my ($nowmo,$nowyr) = (localtime(time))[4,5];
      $yr = ($mon > $nowmo)		# roll over to new year??
	? $nowyr -1
	: $nowyr;
    } elsif ( $yr > 1900 ) {	# most likely
      $yr -= 1900;
    } elsif ( $yr < 70 ) {	# yr 2000 or more
      $yr += 100;
    }				# else leave as-is, 70 - 99
    $time = &Time::Local::timelocal($sec,$min,$hr,$day,$mon,$yr);
  }
# extract ip's and ports                     src              sp                 dest               dp
  return undef unless $line =~ /:\s+(\d+\.\d+\.\d+\.\d+)\s+([na\d]+)[^\d]+(\d+\.\d+\.\d+\.\d+)\s+([na\d]+)/;
  $tp->{now} = $time if (! $tp->{now}) || $tp->{now} < $time;
  my ($src,$sp,$dest,$dp) = ($1,$2,$3,$4);
  delete $tp->{dt}->{$src} if $tp->{dt}->{$src};	# remove dead soldiers
  $_ = $tp->{at}->{$src}->{$sp} || ($tp->{at}->{$src}->{$sp} = {});
  $_->{dip}	= $dest;
  $_->{dp}	= $dp;
  $_->{pst}	= ($line =~ /Persist/i) ? 6 : 0;
  $_->{ct}	= $time unless exists $_->{ct};
  $_->{lc}	= $time;
  if ( $ds && $line =~ /Initial/i ) {			# mark for DShield
    $_->{DShield} = {} unless $_->{DShield};
    $_->{DShield}->{$dest} = {} unless $_->{DShield}->{$dest};
    $_->{DShield}->{$dest}->{$dp} = $time;
  }

  if ( $ph ) {			# if port statistics are collected
    $_ = $tp->{pt} || 86400;
    $time -= ($time % $_);
    if (exists $tp->{ph}->{$time}->{$dp}) {
      $tp->{ph}->{$time}->{$dp} += 1;
    } else {
      $tp->{ph}->{$time}->{$dp} = 1;
    }
  }
  return 1;
}

# process a log file
#
# input:	\%tarpit, $log_file_path_name, is_daemon, port_intvls
# returns:	true or undef on fail
#
sub process_log {
  my ($tp,$logf,$id,$ph) = @_;
  return undef unless open(LOG,$logf);
  $ph = 0 unless $ph;
  while (<LOG>) {
    &log2_mem($tp,$_,$id,$ph);
  }
  close LOG;
  1;
}

# cull threads helper for DShield
# see docs for 'ex_open', condensed version here
#
sub _ex_append {
  my ($LOCK,$fh,$fn) = @_;
  umask 0111;		# sorry about that, needs to be deletable by reader
    return undef unless sysopen $LOCK, $fn . '.flock', O_RDWR|O_CREAT|O_TRUNC;
#       die(&me . ': could not open file exclusive ' . $fn . '.flock');
  unless (flock($LOCK,LOCK_EX)) {
    close $LOCK; 
    return undef;
  }
  unless (sysopen $fh, $fn, O_RDWR|O_APPEND|O_CREAT) {
    close $LOCK;
    return undef;
  }
  my $tmp = select $fh;
  $| = 1;
  select $tmp;
  return 1;   
}

# cull old threads
#
# input:	\%tarpit, timeout_seconds, scanners, port_intervals, DShield_file
#			    default 600
# returns:	1 if threads removed, else 0

sub cull_threads {
  my ($tp,$timeout,$scrs,$ph,$ds) = @_;
  my $rv = 0;
  $scrs = ($scrs && $scrs > 0) ? int($scrs) : 0;
  my %scanners;			# trial dead threads
  my $dso;
  local (*LOCK,*DS);
  $timeout = defaults->{cull} unless $timeout;
  my $now = $tp->{now} || time;
  $tp->{tz} = timezone($now);
  my $expired = $now - $timeout;
  my ($src,$sp,$destdp);
  my $act = $tp->{at} || ($tp->{at} = {});	# pointer to active threads
  my @src = keys %{$act};			# active threads
  foreach $src (@src) {
    my @sp = keys %{$act->{$src}};
    foreach $sp ( sort {
	$act->{$src}->{$a}->{lc} <=> $act->{$src}->{$b}->{lc}
	}@sp) {
# process DShield notifications first
      if ( exists $act->{$src}->{$sp}->{DShield} ) {
	if (! $ds) {						# dshield not active
	  delete $act->{$src}->{$sp}->{DShield};		# don't want these around
	}
	elsif ( $dso || ($dso = _ex_append(*LOCK,*DS,$ds)) ) {	# DShield cache open
	  $_ = $tp->{tz};
	  substr($_,-2,0) = ':';				# insert colon in TZ string
	  my ($tza,$tzb) = split(':',$_);			# crude but effective
	  my $dshield = $act->{$src}->{$sp}->{DShield};
	  foreach my $shieldIP (keys %{$dshield}) {		# foreach dest IP
	    foreach my $shieldPort(keys %{$dshield->{$shieldIP}}) {	# and each target port
	      my($sec,$min,$hr,$md,$mon,$yr) = localtime($dshield->{$shieldIP}->{$shieldPort});
	      $_ = sprintf ("%04d-%02d-%02d %02d:%02d:%02d %+03d:%02d\t",$yr+1900,$mon+1,$md,$hr,$min,$sec,$tza,$tzb);
	      print DS $_,'UserID',$tp->{LaBrea},':',$VERSION,"\t1\t$src\t$sp\t$shieldIP\t$shieldPort\tTCP\tSYN\n";
	    }
	  }
	  delete $act->{$src}->{$sp}->{DShield};		# printed, destroy
	}
      }

      if ( $act->{$src}->{$sp}->{lc} < $expired ) {
	@{$scanners{$src}}{'dp','lc','pst'} = @{$act->{$src}->{$sp}}{'dp','lc','pst'};
	delete $act->{$src}->{$sp};			# remove active expired thread
      }
    }
    if (keys %{$act->{$src}}) {				# do threads remain for this IP?
      delete $scanners{$src};			# yes, dispose of parital deaths
    } else {
      delete $act->{$src};			# no, delete active thread
    }
    $rv = 1;
  }
  if ( $dso ) {		# dshield cache open
    close *DS;
    close *LOCK;
  }
  if ($scrs) {		# if scanners are saved
    my $dead = $tp->{dt} || ($tp->{dt} = {});
# add new dead threads
    foreach (keys %scanners) {
      @{$dead->{$_}}{'dp','lc','pst'} = @{$scanners{$_}}{'dp','lc','pst'};
    }
# remove old dead threads over limit
    if ((@_ = keys %{$dead}) > $scrs) {
      my @dead = sort {
	$dead->{$a}->{lc} <=> $dead->{$b}->{lc};
      } @_;
# extract the oldest dead threads
      splice(@dead,@_-$scrs);
      foreach(@dead) {
	delete $dead->{$_};
      }
      $rv = 1;
    }
  }
  if ( $ph ) {		# if port stats are present
    $_ = $tp->{pt} || 86400;
    my $intvls = $ph * $_;
    my $end = $now - ($now % $_) - $intvls + 1;
    foreach(keys %{$tp->{ph}}) {
      if ($_ < $end) {
	delete $tp->{ph}->{$_};		# drop old port stats
	$rv = 1;
      }
    }
  } elsif (exists $tp->{ph}) {
    delete $tp->{ph};				# remove unwanted port stats
    $rv = 1;
  }
  $rv;
}

# helper routine
#
# input:	\$txtstring, \%tarpit, $type
#	type = static or daemon
#
sub _cache2txt {
  my ($txp,$tp,$type) = @_;
  $tp->{now} = time unless $tp->{now};
  $_ = localtime($tp->{now});
# print info
  $$txp = '_VERSION:' . __PACKAGE__ .
	" $VERSION $type\n_CACHEDUMP:$_\n";
  $tp->{bw} = 0 unless $tp->{bw};	# must have a value
  $tp->{tz} = &timezone($tp->{now});
  &recurse_hash2txt($txp,$tp,'');
}

# write new db
#
# input:	\%tarpit,$db_file_path_name [umask], fork
# return:	cache text or false on fail
#
sub write_cache_file {
  my ($tp, $dbf, $umask, $flag) = @_;
  return undef unless $dbf;
  local *DB;
  $flag = ($flag) ? 'daemon' : 'static';
  $umask = 033 unless $umask;
  umask $umask;
  return undef unless open(DB,'>'.$dbf.'.tmp');
  $_ = select DB;
  $| = 1;
  select $_;
  my $cache_txt = '';
  &_cache2txt(\$cache_txt,$tp,$flag);
  print DB $cache_txt;
  close DB;
  return (rename ($dbf.'.tmp', $dbf)) ? $cache_txt : undef;
}

# helper routine
#
# input:	\%hash, key
# returns:	pointer to cleared array or undef
#
sub _init_pt {
  my ($p,$k) = @_;
  return undef unless exists $p->{$k};
  @{$p->{$k}} = ();
  $p->{$k};
}

# helper routine
#
# input: 	\@array_of_digits, $match
# return:	number of matching digits
#
sub _add_array {
  my ($ary, $mat) = @_;
  my $sum = 0;
  foreach(@{$ary}) {
    ++$sum if $_ == $mat;
  }
  return $sum;
}

sub prep_report {
  my ($tp,$p) = @_;
# establish array pointers / flags
  my ($tgsip,$tgsp,$tgdip,$tgdp,$tgcap,$tglst,$tgpst);
  my ($thsip,$thnum);
  my ($csdays,$csdate,$csctd);
  my ($phdip,$phpst);
  my ($scsip,$scdp,$scpst,$sclst);
  my ($pintvls,$ports,$pstats);

  my $TCP = 6;		# persistent protcol

  $p->{LaBrea} = $tp->{LaBrea} || 'unknown';
  my (@now,%phantoms,%threadays);
  $now[0] = $p->{now} = $tp->{now} || time;
  $tp->{tz} = &timezone($now[0]) unless $tp->{tz};
  my $tz = $tp->{tz};

  if (exists $p->{tg_srcIP} && exists $p->{tg_sPORT}) {
    $tgsip	= $p->{tg_srcIP};
    $tgsp	= $p->{tg_sPORT};
    $tgdip	= &_init_pt($p,'tg_dstIP');
    $tgdp	= &_init_pt($p,'tg_dPORT');
    $tgcap	= &_init_pt($p,'tg_captr');
    $tglst	= &_init_pt($p,'tg_last');
    $tgpst	= &_init_pt($p,'tg_prst');

  }
  if ($thsip = &_init_pt($p,'th_srcIP')) {
    $thnum	= &_init_pt($p,'th_numTH');
  }
  if ($p->{cs_days} && exists $p->{cs_date} && exists $p->{cs_ctd}) {
    $csdays	= $p->{cs_days};
    $csdays	= ($p->{cs_days} && $p->{cs_days} > 1)
	? $p->{cs_days}
	: 2;
    $csdate	= &_init_pt($p,'cs_date');
# default 'capture this date'
    $csctd	= &_init_pt($p,'cs_ctd');
    $now[0] = $p->{now};
    foreach(1..$csdays-1) {
      $now[$_] = $now[$_-1] - 86400;	# previous days
    }
    foreach(0..$#now) {
      $now[$_] = midnight($now[$_],$tz);
    }
  }
  if (&_init_pt($p,'ph_dstIP')) {
    $phdip	= $p->{ph_dstIP};
    $phpst	= &_init_pt($p,'ph_prst');
  }
  if (&_init_pt($p,'sc_srcIP')) {
    $scsip	= $p->{sc_srcIP};
    $scdp	= &_init_pt($p,'sc_dPORT');
    $scpst	= &_init_pt($p,'sc_prst');
    $sclst	= &_init_pt($p,'sc_last');
  }

  my ($tot,$tg,$th,$cs) = (0,0,0,0);	# event counters

  my $act = $tp->{at} || ($tp->{at} = {});

  my @src = sort keys %$act;
  $p->{total_IPs} = @src;		# total hosts teergrubed

  foreach my $src (@src) {		# each black host
    my @sp = sort keys %{$act->{$src}};
    $tot += @sp;
    if ($thsip) {
      $thnum->[$th] = @sp if $thnum;
      $thsip->[$th++] = $src;		# threads per IP report
    }
    foreach my $sp (@sp) {
      $phantoms{$act->{$src}->{$sp}->{dip}}	# prep phantoms report
	= $act->{$src}->{$sp}->{pst} if $phdip;
      if ($csdate) {			# capture report
	my $capt = &midnight($act->{$src}->{$sp}->{ct},$tz);
	$threadays{$capt} = (exists $threadays{$capt}) 
		? $threadays{$capt} + 1
		: 1;
	$cs++;
      }
      if ($tgsip) {			# teergrube report
	$tgdip->[$tg]	= $act->{$src}->{$sp}->{dip} if $tgdip;
	$tgdp->[$tg]	= $act->{$src}->{$sp}->{dp}  if $tgdp;
	$tgcap->[$tg]	= $act->{$src}->{$sp}->{ct}  if $tgcap;
	$tglst->[$tg]	= $act->{$src}->{$sp}->{lc}  if $tglst;
	$tgpst->[$tg]	= $act->{$src}->{$sp}->{pst} if $tgpst;
	$tgsip->[$tg]	= $src;
	$tgsp->[$tg++]	= $sp;
      }
    }
  }
  if ($phdip) {				# complete phantoms report
    $p->{phantoms} = @_ = sort keys %phantoms;
    @{$phdip}	= @_;
    if ($phpst) {
      @{$phpst} = @phantoms{@_};
      $p->{ph_capt} = &_add_array($phpst,$TCP);
    }
  }
  if ($csdate) {			# finish capture report
    my $k = 0;
    foreach(0..$#now-1) {  
      $csdate->[$_]	= $now[$_];
      $csctd->[$_]	= $threadays{$now[$_]} || 0;
      $k 	       += $csctd->[$_];
    }
    $csdate->[$#now]	= $now[$#now];
    $csctd->[$#now]	= $cs - $k;
  }

# build report elements
  $p->{tz} = $tz;
  $p->{bw} = &bandwidth($tp);
  $p->{threads} = $tot;

# fill remaining conditional
  $p->{tg_capt} = &_add_array($tgpst,$TCP) 
	if $tgsip && $tgpst;

# this one is really totally independent
  if ($scsip) {				# dropped scanner report
    my $dead = $tp->{dt} || ($tp->{dt} = {});
    $p->{sc_total} = @{$scsip} = @_= sort keys %$dead;
    foreach(0..$#_) {
      $scdp->[$_]	= $dead->{$_[$_]}->{dp}	 if $scdp;
      $sclst->[$_]	= $dead->{$_[$_]}->{lc}	 if $sclst;
      $scpst->[$_]	= $dead->{$_[$_]}->{pst} if $scpst;
    }
    $p->{sc_capt} = &_add_array($scpst,$TCP) if $scpst;
  }

# ports also totally independent
  if (exists $p->{port_intvls} &&
	$p->{port_intvls} &&
	exists $p->{ports} &&
	exists $p->{portstats}) {	# port statistics report

    $pintvls = $p->{port_intvls};
    $p->{pt} = $tp->{pt} || 86400;
    $ports = $p->{ports};
    $pstats = $p->{portstats};
    @now = $p->{now};
    $now[0] -= ($now[0] % $p->{pt});
    foreach(1..$pintvls-1) {
      $now[$_] = $now[$_ -1] - $p->{pt};	# fill now with intvls of interest
    }
  # get port numbers so we have them all
    my @pnums;
    foreach (@now) {
      push @pnums, (keys %{$tp->{ph}->{$_}})
	if exists$tp->{ph}->{$_};
    }
    @_ = sort { $a <=> $b } @pnums;
    @pnums = ();
    my $lastp = 0;			# no port zero
    foreach (@_) {			# remove duplicates
      next if $_ == $lastp;
      $lastp = $_;
      push @pnums, $lastp;
    }
    @$ports = @pnums;			# export ports
    @$pstats = ();			# clear stats
    foreach(0..$#pnums) {		# fill stats array
      my $i = $pintvls * $_;		# index into array for port
      foreach my $d (0..$#now) {	# get data for each time slice
        ${$pstats}[$i+$d] = $tp->{ph}->{$now[$d]}->{$pnums[$_]} || 0;
      }
    }
  }
}

sub find_old_threads {
  my ($tp,$rpt,$age,$testime) = @_;
  $age *= 86400;				# age in days
  my $now = $testime || time;
  my $act = $tp->{at} || ($tp->{at} = {});	# pointer to active threads
  my @src = keys %{$act};			# active threads
  foreach my $src (@src) {
    my @sp = keys %{$act->{$src}};                              
    foreach my $sp (@sp) {
      my $ct = $act->{$src}->{$sp}->{ct};
      $rpt->{"${src}:${sp} -> $act->{$src}->{$sp}->{dp}"} = $ct
	if $ct + $age < $now;
    }
  }
  return scalar keys %$rpt;
}

#=item * $rv = refresh_cache_file($path2_pid_file,$path2_cache_file,$age);
#
#  DEPRECATED and REMOVED
#
#  Refresh (update) the cache file from the daemon memory
#  if the cache file is older than $age seconds. Ages of
#  zero or less force an immediate update.
#
#  Returns 0 (false) if the cache is current or when updated,
#  otherwise returns the ERRNO for the fault
#
#  WARNING: this only works if you have the necessary
#  file and daemon permissions. Normal usage to gain access
#  memory cache would be to read from the daemon pipe.
#
## conditionally refresh the cache file
##
## input:	$path2_pid_file, $path2_cache_file, $age
## returns:	errno or 0 on 'up 2 date'
##
#sub refresh_cache_file {
#  my ($pid,$p2cf,$age) = @_;
#  return ($! = ENOENT) unless -e $pid;	# validate pid file
#  return ($! = EACCES) unless -r $pid;
#  $age = defaults->{min_age} 
#	unless $age &&
#	  int($age) > 0;
#  $age = time - $age;				# benchmark time
#  if ( -e $p2cf ) { 				# cache file is present
#    return ($! = EACCES) unless -r $p2cf;	# validate it
#    return 0 if (stat($p2cf))[9] >= $age	# return if current
#  }
#  local(*F,*W);
#  return ($! = EACCES) unless open(F,$pid);
#  read(F, $pid, 100);				# slurp PID file
#  close F;
#  return EINVAL unless ($pid =~ /(\d+)/);	# pid -> $1
#  return $! unless kill 0, $pid;		# check for process alive
#  kill 1, $1;					# send HUP to daemon
#  pipe(F,W);					# open NULL handle
#  my $rin = '';
#  my $rout;
#  vec($rin,fileno(F),1) = 1;
#  my $timer = defaults->{s_timeout} || .1;	# may not be zero
#  my $hup_timeout = int(defaults->{hup_timeout} / $timer);
#  while(1) {
#    $_ = select($rout=$rin,undef,undef,$timer);
#    read(F,$_,1) if $_;				# should never happen
#    if ((stat($p2cf))[9] >= $age ) {
#      $! = 0;
#      last;
#    }
#    unless ($hup_timeout-- > 0) {
#      $! = ETIME;
#      last;
#    }
#  }
#  close W;
#  close F;
#  $!;
#}
#

1;