LaBrea::Tarpit::DShield - LaBrea::Tarpit::DShield documentation

  use LaBrea::Tarpit::DShield qw ( .... );

  $rv = chk_config(\%config);
  $rv = mail2_Q(\%config,\$message,[subject]);
  $rv = move2_Q(\$config);
  $rv = deliver2_DShield(\%config);
  $rv = process_Q(\%config);

	chk_config
	deliver2_DShield
	move2_Q

#!/usr/bin/perl
package LaBrea::Tarpit::DShield;
#
use strict;
#use diagnostics;

use vars qw($VERSION @ISA @EXPORT_OK *deliver2_DShield);
use Fcntl qw(:DEFAULT :flock);
use Net::Netmask;

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

require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(
	chk_config
	deliver2_DShield
	process_Q
	move2_Q
	mail2_Q
);

*deliver2_DShield = \&process_Q;

sub chk_config {
  my ($cfg) = @_;
  return "missing DShield queue directory"
	unless $cfg->{DShield};
# add leading ./ if missing
  $cfg->{DShield} = './' . $cfg->{DShield}
	unless $cfg->{DShield} =~ m|/|;

  my $emailfmt = '^.+\@.+\..+';		# required e-mail format
  return "missing or invalid To: email format"
	unless $cfg->{To} && $cfg->{To} =~ /$emailfmt/;
  return "missing or invalid From: email format"
	unless $cfg->{From} && $cfg->{From} =~ /$emailfmt/;
  $cfg->{'Reply-To'} = $cfg->{From} unless exists $cfg->{'Reply-To'};
  return "invalid Reply-To: email format"
	unless defined $cfg->{'Reply-To'} &&
			$cfg->{'Reply-To'} =~ /$emailfmt/;
  return "unknown Obfuscate word: '$cfg->{Obfuscate}'"
	if $cfg->{Obfuscate} &&
	   ( $cfg->{Obfuscate} !~ /^partial$/i &&
	     $cfg->{Obfuscate} !~ /^complete$/i );
  return "missing mail agent"
	unless $cfg->{smtp} || $cfg->{sendmail};
  return "sendmail agent missing or not executable"
	if $cfg->{sendmail} &&
	   $cfg->{sendmail} =~ /^([\S]+)/ &&
	   ! -e $1 && 
	   ! -x $1;
  return undef;
}
  

sub mail2_Q {
  my ($cfg,$mp,$sub) = @_;
  return "no message content" unless $mp && $$mp =~ /\S/;
  $sub = 'not specified' unless $sub =~ /\S/;
  return $_ if ($_ = chk_config($cfg));
  my $f = $cfg->{DShield};
  $f =~ m|(.*/)|;
  my $dir = $1;  
  return "queue directory $dir not writable"
	unless -d $dir && -w $dir;
  local(*LOCK,*IN,*OUT);  
# open mail.q.tmp
  return $_ if ($_ = open_Q(*LOCK,*OUT,$dir . 'mail'));
# now format the Q file output
  print OUT qq|From: $cfg->{From}
To: $cfg->{To}
Reply-To: $cfg->{'Reply-To'}
X-mailer: LaBrea-DShield $VERSION
Subject: $sub

$$mp
|;
  close OUT;
  rename $dir . 'mail.q.tmp', $dir . 'qF'. time .'.'. $$ .'.'. 2;
  close LOCK;
  return undef;
}

# helper routine opens Q files
#
# input:	LOCK, OUT handle pointers, file name
# returns:	error message on failure
# returns:	undef on success
#
  
sub open_Q {
  my ($LOCK,$OUT,$f) = @_;
  return "failed to open lockfile ${f}.flock" unless
	sysopen $LOCK, $f . '.flock', O_RDWR|O_CREAT|O_TRUNC;
  unless (flock($LOCK,LOCK_SH)) {
	close $LOCK;
	return "failed to lock $f";
  }
  unless (open($OUT,'>'.${f}.'.q.tmp')) {
	close $LOCK;
	return "failed to open $f.q.tmp for write";
  }
  $_ = select $OUT;
  $| = 1;
  select $_;
  return undef;
}

# $debug	= true, do not delete 'dshield.cache'
# $debug	> 1, as above and do not rename 'dshield.cache.q.tmp'
 
sub move2_Q {
  my ($cfg,$debug) = @_;
  return "missing DShield UserID"
	unless  exists $cfg->{UserID} &&
		defined $cfg->{UserID} &&
		$cfg->{UserID} !~ /\D/;
  my $tmp = chk_config($cfg);
  return $tmp if $tmp;		# return existing config errors
  my $f = $cfg->{DShield};
  return undef unless -e $f && -r $f;	# nothing to do
  return "$f not a plain file" unless -f $f;
  $f =~ m|(.*/)|;
  my $dir = $1;
  return "queue directory $dir not writable"
	unless -d $dir && -w $dir;
  local (*LOCK,*IN,*OUT);
  return $_ if ($_ = open_Q(*LOCK,*OUT,$f));
  unless (open(IN,$f)) {
	close OUT;
	close LOCK;
	return "failed to open $f for read"
  }

  my @SrcIgnoreBlocks = ();
  if ($cfg->{SrcIgnore}) {
      my($blockstr,$block);
      for $blockstr (@{$cfg->{SrcIgnore}}) {
	  return "failed to allocate Net::Netmask"
		unless $block = new Net::Netmask($blockstr);
	  push(@SrcIgnoreBlocks, $block);
      }
  }

# now format the Q file output
  print OUT qq|From: $cfg->{From}
To: $cfg->{To}
Reply-To: $cfg->{'Reply-To'}
X-mailer: LaBrea-DShield $VERSION
|;

  $tmp = 1;	# line count, flag
  my $ver = '';
  my $entries = 0;

DSLINE:
  while(my $in = <IN>) {
#					   $1        $2                $3              $4                  $5      $6
#                    date     time         tza       tzb            version   count   src         sp     1stQuad  dest      dp proto flags
    unless ($in =~ /[^\s]+\s+[^\s]+\s+([\+\-0-9]+):([0-9]+)\s+UserID([^\s]+)\s+\d+\s+([^\s]+)\s+[^\s]+\s+(\d+)\.([^\s]+)\s+[^\s]+\s+\w+\s+\w+/) {
      chop $in;
      close OUT;
      close IN;
      unlink ${f}.'.q.tmp';
      close LOCK;
      return "line $tmp corrupt: $in";
    }
    unless ( $ver ) {		# Subject printed yet??
      $ver = $3;		# nope, mark and print
      print OUT "Subject: FORMAT DSHIELD USERID $cfg->{UserID} TZ $1:$2 LaBrea_Tarpit_DShield ${ver}:$VERSION\n\n";
    }
    foreach my $block (@SrcIgnoreBlocks) {
	next DSLINE if $block->match($4);
    }
    if (exists $cfg->{Obfuscate}) {
      my $dest = $5 .'.'.$6;
      my $rplc = ($cfg->{Obfuscate} =~ /complete/i)
	? '10.0.0.1'		# complete
	: '10.' . $6;		# partial
      $in =~ s/$dest/$rplc/;
    }
# insert DShield ID
    $in =~ s/UserID${ver}/$cfg->{UserID}/;
    print OUT $in;
    $entries++;
  }
  close OUT;
  close IN;
  if ($entries) { # Only send mail if matching entries were found.
    rename ${f}.'.q.tmp', $dir . 'qF'. time .'.'. $$ .'.'. 0
	unless $debug && $debug > 1;
  } else {
    unlink ${f}.'.q.tmp' unless $debug && $debug > 1;
  }

  $debug = ($debug || unlink $f) ? 0
	: "cannot unlink $f: Operation not permitted";
  close LOCK;
  return $debug;
}

# input:	\$config, $debug
# returns:	error message
#		or false on success
#
#	$debug true will create a file called
#	dF{time.pid} . '.smtp'	containing the mail output
#	  or
#	dF{time.pid} . '.sendmail'
#
#	$debug > 1, will not delete queue files after processing
#
#	SEE: RFC-821 for SMTP codes
#
sub process_Q {
  my ($cfg,$debug) = @_;
  my $tmp = chk_config($cfg);
  return $tmp if $tmp;

# FOR NOW
my $me = 'localhost';

  $cfg->{DShield} =~ m|(.*/)|;
  my $dir = $1;
  return "$dir not a directory or not writable"
	unless -d $dir && -w $dir;
  local(*M,*QF);
  my $M = *M;
  return "could not open directory $dir"
	unless opendir($M,$dir);
  my @qfiles = grep(/^qF/,readdir(M));
  closedir $M;
  return undef unless @qfiles;		# punt if nothing to do

  my $smtp = ($cfg->{smtp}) ? 1 : 0;

  local $SIG{ALRM} = sub {die 'failed: 554 timeout ';};

## define valid SMTP response codes for each action
#
  my $resp = {
	'CONN'	=> [220],
	'HELO'	=> [250],
	'MAIL'	=> [250],
	'RCPT'	=> [250,251],
	'DATA'	=> [354],
	'ATAD'	=> [250],	# the "period" '.'
	'QUIT'	=> [221],
  };

  my $err;
  foreach my $qf (@qfiles) {
    if ($debug) {
      $tmp = ($smtp)
	? $dir . $qf . '.smtp'
	: $dir . $qf . '.sendmail';
      $tmp =~ s/qF/dF/;
      return "could not open debug file $tmp"
	unless open($M,'>'. $tmp);
    }
    elsif ( $smtp ) {			# is SMTP
      require LaBrea::NetIO;
      my @smtp_hosts = split(',',$cfg->{smtp});
      foreach (@smtp_hosts) {
        $tmp = LaBrea::NetIO::open_tcp($M,$_,25);
	last unless $tmp;
      }
      return $tmp if $tmp;		# punt if error
    }
    else {				# must be sendmail
      return "could not open sendmail"
	unless open($M,"|$cfg->{sendmail}");
    }

    $tmp = $dir . $qf;
    unless (open(QF,$tmp)) {		# sigh.... kill this loop
      close $M;
      next;
    }

# actually send the mail now
    eval {

      alarm 240;			# 4 minutes to complete task
      if ($smtp) {
	slurp($M,'CONN',$resp,$debug);	# connect

	syswrite($M,"HELO $me\n");
	slurp($M,'HELO',$resp,$debug);	# hello

        my $line = <QF>;		# LINE one, From:
	syswrite($M,'MAIL ' . $line);
	slurp($M,'MAIL',$resp,$debug);	# mail From:

	$line = <QF>;
	syswrite($M,'RCPT ' . $line);
	slurp($M,'RCPT',$resp,$debug);	# receipient To:

	syswrite($M,"DATA\n");		# rest of headers and message follow
	slurp($M,'DATA',$resp,$debug);

        while ($line = <QF>) {		# send the rest
	  syswrite($M,$line);		# 
	}
	syswrite($M,'.'."\n");		# terminate with period
	slurp($M,'ATAD',$resp,$debug);	# Got confirmation

	syswrite($M,"QUIT\n");
	slurp($M,'QUIT',$resp,$debug);
      }
      else {	# IT's sendmail or equivalent
	while (<QF>) {
	  syswrite($M,$_);
	}
      } # done
    };	# end eval
    alarm 0;
    close QF;
    close $M;
    if ($@) {
      $err = ( $@ =~ /^(failed:\s+\d+\s+\w+)/ )
	? $1 : $@; #'failed: 554 unknown';
    } else {
      unlink $dir . $qf unless $debug && $debug > 1;
    }
  }
  return $err;
}

# helper subroutine to get responses from SMTP servers
#
# input:	handle, action, \%valid_response, $debug
# returns:	true if OK to proceed
#		else DIES
sub slurp {
  my ($S,$act,$rsp,$debug) = @_;
  return 1 if $debug;		# skip
  my $buf;
  sysread($S,$buf,1024);	# better not be longer than this
  my $code;
  foreach(@{$rsp->{$act}}) {
    next unless $buf =~ /^(\d+)/;
    $code = $1;
    return $code if $code == $_;
  }
# bummer, didn't get a response
  if ( $act !~ /QUIT/i ) {	# don't wait on quit, won't do any good
    alarm 10;			# give it 10 seconds
    syswrite($S,"QUIT\n");
    sysread($S,$buf,1024);	# try to complete the transaction
  }
  $code = 554 unless $code;
  $code = sprintf("failed: %03d ",$code) . $act;
  die $code;
}

1;
__END__