#!/usr/local/bin/perl -Tw
# spamtrak -- Read an email message in and send complaints to admins.
# Written by Stanislav Shalunov <shalunov@internet2.edu>
# $Id: spamtrak,v 1.2 2001/08/25 05:11:47 shalunov Exp $

BEGIN {
  $ENV{PATH} = '/bin:/usr/bin:/usr/local/bin';
  delete $ENV{BASH_ENV};
  delete $ENV{IFS};
  delete $ENV{ENV};
}

use strict;
use Getopt::Std;
use Socket;

my $sendmail;
for (qw(/usr/sbin/sendmail /usr/lib/sendmail)) {
  if (-x) {
    $sendmail = $_;
    last;
  }
}

die "could not find sendmail\n" unless $sendmail;

my $rbl_dom = '.rbl.maps.vix.com.';
my $dul_dom = '.dialups.mail-abuse.org.';
my $orbs_dom = '.outputs.orbz.org.';
my $orbs_addr = 'qspam@orbs.org, open-relay@orbl.org';

my %domains;
my @domain_files = qw(/etc/mynets);
push @domain_files, $ENV{HOME} . '/.mynets';

my %options;
getopts('v', \%options) or usage();
my $verbose = $options{v};

init_domains();

$/ = '';
my $header = my $in_header = <STDIN>;
undef $/;
my $body = my $in_body = <STDIN>;
$header =~ s/\n\s+/ /g;      # merge continuation lines
my ($peer, $origin);
HEADER: for (split /\n/, $header) {
  /^received:.*[([](\d+\.\d+\.\d+\.\d+)[])]/i or next;
  my $ip = $1;
  interesting($ip) or next;
  if (!$peer) {
    $peer = $ip;
    next HEADER;
  }
  if (!$origin) {
    # If origin and peer are in the same /24, there's no point in using both.
    my @o = split /\./, $peer;
    my @n = split /\./, $ip;
    next HEADER if $o[0] == $n[0] and $o[1] == $n[1] and $o[2] == $n[2];
    $origin = $ip;
    last HEADER;
  }
}

my $in_rbl = rbl_map($rbl_dom, $peer) if $peer;
my $in_dul = rbl_map($dul_dom, $peer) if !$in_rbl and $peer;
my $in_orbs = rbl_map($orbs_dom, $peer) if !$in_dul and !$in_rbl and $peer;
undef $origin if $in_dul or $in_rbl;	# Don't trust DUL or RBL hosts.

submit_to_orbs($peer) if !$in_dul and !$in_orbs and $peer;
complain($peer, 'spam delivery host') if $peer;
complain($origin, 'spam origin') if $origin;

exit 0;

# Submit a given IP to ORBS.
sub submit_to_orbs {
  my $ip = shift @_;
# XXX: open(SENDMAIL, "|$sendmail -oi $orbs_addr") or return;
  print  <<EOT;
To: $orbs_addr
Subject: spamtrak submission

Relay: $ip
EOT
#  close SENDMAIL;
}

# Initialize %domains.  Put local and reserved networks there.
sub init_domains {
  for my $file (@domain_files) {
    if (open MYNETS, $file) {
      while(<MYNETS>) {
	s/#.*//;
	s/^\s*//;
	s/\s*$//;
	/^\d+\.\d+\.\d+\.\d+\/\d+$/ or next;
	$domains{$_} = 1;
      }
      close MYNETS;
    }
  }
  for (qw(127.0.0.0/8
	  10.0.0.0/8
	  0.0.0.0/8
	  169.254.0.0/16
	  172.16.0.0/12
	  192.0.2.0/24
	  192.168.0.0/16
	  224.0.0.0/4
	  240.0.0.0/5
	  248.0.0.0/5
	  255.255.255.255/32
	)) {
    $domains{$_} = 1;
  }
}

# See whether we're looking at a good foreign IP.
sub interesting {
  my $ip = shift @_;
  my @octets = split /\./, $ip;
  return undef unless @octets == 4;
  for (@octets) {
    return undef if /^0\d/;
    return undef if $_>255;
  }
  for (my $bits = 32, my $mask = 0xffffffff;
       $bits; $bits--, $mask <<= 1) {
    my $p = unpack("N", inet_aton($ip));
    my $key = inet_ntoa(pack("N", $p & $mask)) . "/" . $bits;
    return undef if $domains{$key};
  }
  return 1;
}

# See if IP is in given RBL-style map.
sub rbl_map {
  my ($base, $ip) = @_;
  my $rev = join '.', reverse split /\./, $ip;
  return !system 'host', '-ta', $rev . $base;
}

# Send complaint about given IP for a given reason
sub complain {
  my ($ip, $reason) = @_;
  my @octets = split /\./, $ip;
  pop @octets;
  my $dom;
  my $zone = join('.', @octets) . '.in-addr.arpa.';
  open HOST, "host -v -t soa $zone 2>&1|";
  while(<HOST>) {
    next unless /\sIN\s+SOA\s+\S+\s+(\S+)\s*\(/i;
    $dom = $1;
    last;
  }
  close HOST;
  return unless $dom;
  $dom =~ s/^[^.]+\.//;
  $dom =~ s/[^a-z0-9._-]//ig;
  print "DEBUG: sending complaint; reason = $reason, dom = $dom\n";
  my $abuse = whois($dom) || 'postmaster@' . $dom;
  #open SENDMAIL, "|$sendmail -oi -t";
  print  <<EOT;
To: $abuse
Subject: spamtrak: $ip: $reason

Please find the original message appended:

$in_header

in_body
EOT
  #close SENDMAIL;
}

sub whois {
  my ($dom) = @_;
  my $iaddr   = inet_aton('whois.abuse.net') or return undef;
  my $paddr   = sockaddr_in(43, $iaddr);
  socket(SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp')) or return undef;
  connect SOCK, $paddr or return undef;
  select SOCK;
  local $/ = "\n";
  local $| = 1;
  print "$dom\015\012";
  select STDOUT;
  my $response = <SOCK>;
  print "DEBUG: whois.abuse.net response for $dom = $response";
  close SOCK;
  $response =~ s/\s*$//s;
  return undef if $response =~ /\(default, no info\)/;
  return $response;
}