# Before
ake install' is performed this script should be runnable with
# `make test'. After
ake install' it should work as `perl test.pl'
######################### We start with some black magic to print on failure.
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
BEGIN { $| = 1; print "1..47\n"; }
END {print "not ok 1\n" unless $loaded;}
require LaBrea::Tarpit;
import LaBrea::Tarpit qw(
log2_mem
write_cache_file
recurse_hash2txt
bandwidth
timezone
cull_threads
restore_tarpit
);
$loaded = 1;
print "ok 1\n";
my $cache_file = './labrea.cache.tmp';
unlink $cache_file if -e $cache_file;
$test = 2;
sub ok {
print "ok $test\n";
++$test;
}
# wait til beginning of next second
#
sub nextsec {
my $dAge = time;
my $time;
while ( do {$time = time; $dAge == $time} ) {select(undef,undef,undef,0.1);}; # wait for second to tick over
return $time;
}
sub recurse {
my ($tp) = @_;
&recurse_hash2txt(@_);
my @txt = split('\n',$$tp);
@_ = sort @txt;
$$tp = join("\n",@_,'');
}
my %tarpit;
# load some stuff in memory
my @lines = split(/\n/, q
|## bunch that will be timed out test
this will timeout: 67.97.64.10 10 -> 29.31.45.100 100 3
this will timeout: 67.97.64.11 11 -> 29.31.45.101 101 4
this will timeout: 67.97.64.12 12 -> 29.31.45.102 102 5
this will timeout: 67.97.64.13 13 -> 29.31.45.103 103 6
this will timeout: 67.97.64.14 14 -> 29.31.45.104 104 7
this will timeout: 67.97.64.15 15 -> 29.31.45.105 105 8
this will timeout: 67.97.64.16 16 -> 29.31.45.106 106 9
this will timeout: 67.97.64.17 17 -> 29.31.45.107 107 10
this will timeout: 67.97.64.18 18 -> 29.31.45.108 108 11
this will timeout: 67.97.64.19 19 -> 29.31.45.109 109 12
this will timeout: 67.97.64.20 20 -> 29.31.45.110 110 13
this will timeout: 67.97.64.21 21 -> 29.31.45.111 111 14
this will timeout: 67.97.64.22 22 -> 29.31.45.112 112 15
this will timeout: 67.97.64.23 23 -> 29.31.45.113 113 16
this will timeout: 67.97.64.24 24 -> 29.31.45.114 114 17
this will timeout: 67.97.64.25 25 -> 29.31.45.115 115 18
this will timeout: 67.97.64.26 26 -> 29.31.45.116 116 19
this will timeout: 67.97.64.27 27 -> 29.31.45.117 117 20
this will timeout: 67.97.64.28 28 -> 29.31.45.118 118 21
this will timeout: 67.97.64.29 29 -> 29.31.45.119 119 22
## single hit, pst=1 ct=lc 23
Persist Activity: 67.97.64.173 61623 -> 63.77.172.50 80 24
## single hit, same IP, different thread 25
Persist Activity: 67.97.64.173 61624 -> 63.77.172.51 80 26
## single hit, same IP, different thread 27
Persist Activity: 67.97.64.173 61625 -> 63.77.172.52 80 28
## double hit, pst=0 ct!=lc 29
Initial Connect (tarpitting): 63.204.44.126 2014 -> 63.77.172.38 80 30
Additional Activity: 63.204.44.126 2014 -> 63.77.172.38 80 31
## single hit, same IP, different thread 32
Additional Activity: 63.204.44.126 2015 -> 63.77.172.39 80 33
## single hit, pst=1 ct=lc 34
Persist Activity: 63.227.234.71 4628 -> 63.77.172.57 80 * 35
## double hit pst=1 ct!=lc 36
Initial Connect (tarpitting): 63.222.243.6 2710 -> 63.77.172.16 80 37
Persist Trapping: 63.222.243.6 2710 -> 63.77.172.16 80 38
## single hit, pst=1 ct=lc 38
Persist Activity: 216.82.114.82 3126 -> 63.77.172.50 80 40
## double hit pst=1 ct!=lc 41
Initial Connect (tarpitting): 63.14.244.226 4166 -> 63.77.172.18 80 42
Persist Trapping: 63.14.244.226 4166 -> 63.77.172.18 80 * 43
|);
my $basetime = &nextsec;
my $time =$basetime - 30; # introduce 30 sec aging
## add time tags for realtime cache aging
for(my $i=$#lines; $i>=0; $i--) {
$lines[$i] = $time . ' ' . $lines[$i];
$time -= 60; # one minute log intervals
}
my %ansa; # answer array
my $chktm = $basetime - 600; # check defaults first
# input: \%tarpit,\%ansa,$cull,\@lines,$chktm
#
# $cull true = keep cull answers else don't
#
sub loadT {
my ($tp,$arp,$cull,$ary,$ck) = @_;
foreach my $line (@{$ary}) {
if ( $line =~
# time=$1 src=$2 sp=$3 dest=$4 dp=$5 tnm=$6
/^(\d+)\s+.+\s+(\d+\.\d+\.\d+\.\d+)\s+(\d+)\s+.+\s+(\d+\.\d+\.\d+\.\d+)\s+(\d+).+(\d+)$/ ) {
# ignore comment lines
my ($time,$src,$sp,$dest,$dp,$tnm) = ($1,$2,$3,$4,$5,$6);
if ($time > $ck) {
$arp->{at}->{$src}->{$sp}->{dip} = $dest;
$arp->{at}->{$src}->{$sp}->{dp} = $dp;
$arp->{at}->{$src}->{$sp}->{lc} = $time;
$arp->{at}->{$src}->{$sp}->{ct} = $time unless $arp->{at}->{$src}->{$sp}->{ct};
$arp->{at}->{$src}->{$sp}->{pst} = ($line =~ /persist/i) ? 6 : 0;
} elsif ($cull) { # if cull test comming
$arp->{dt}->{$src}->{dp} = $dp;
$arp->{dt}->{$src}->{lc} = $time;
$arp->{dt}->{$src}->{pst} = ($line =~ /persist/i) ? 6 : 0;
}
}
print "failed to load line:\n$line\nnot "
unless log2_mem($tp,$line,1) ||
$line =~ /\d+\s+#/;
&ok;
}
foreach(keys %{$arp->{dt}}) {
delete $arp->{dt}->{$_} if exists $arp->{at}->{$_};
}
}
&loadT(\%tarpit,\%ansa,1,\@lines,$chktm);
$ansa{bw} = 0;
$ansa{tz} = timezone($basetime);
$ansa{now} = $basetime;
my $txt = '';
## &recurse(\$txt,\%ansa,'$tp',1);
## print $txt;
## cull with defaults
## test 44
$tarpit{now} = $basetime;
&cull_threads(\%tarpit,'',1000);
## test 44 -- first real test
## write hash to file
print "failed to open $cache_file\nnot "
unless &write_cache_file(\%tarpit,$cache_file);
&ok;
%tarpit = (); # clear memory cache
## test 45 attempt to open non-existent memory file
print "opened non-existent file\nnot "
if restore_tarpit(\%tarpit,'./someRandomString');
&ok;
## restore cache to memory
## test 46
print "failed to open $cache_file\nnot "
unless restore_tarpit(\%tarpit,$cache_file);
&ok;
## verify restored cache against original
## test 47
$txt = '';
&recurse(\$txt,\%tarpit,'$tp',1);
my $ans = '';
&recurse(\$ans,\%ansa,'$tp',1);
print " response:
${txt} ne expected:
$ans\nnot " unless $txt eq $ans;
&ok;