#!/usr/bin/perl 
#
# milter-uri - Proof-of-concept code for URI blocking at the MTA level.
# Copyright (C) 2006 - Steve Freegard (steve.freegard@fsl.com).
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
#
# INSTALLATION:
# 1) Install Sendmail::PMilter and SpamAssassin.
# 2) Create the directory /etc/milter-uri
# 3) Copy 20_uri_tests.cf from the SpamAssassin install to /etc/milter-uri
# 4) Add the following to sendmail.mc:
#    INPUT_MAIL_FILTER(`milter-uri', `S=local:/var/run/milter-uri.sock, T=C:1m;S:10s;R:10s;E:1m')dnl
# 5) Rebuild sendmail.cf 
# 6) Start the milter
# 7) Restart sendmail
#

use Carp qw(verbose);
use Sendmail::PMilter qw(:all);
use Mail::SpamAssassin;
use Sys::Syslog qw( :DEFAULT setlogsock);
use POSIX qw(setsid);

my $miltername = "milter-uri";

# Set process name
$0 = $miltername;

my($sa);

sub init() {
 # Log
 Log('info',"Initialising SpamAssassin version $Mail::SpamAssassin::VERSION");
 # Initialise SpamAssassin
 $sa = new Mail::SpamAssassin({debug => 0,
                               rules_filename => '/etc/milter-uri',
                               site_rules_filename => '/etc/milter-uri',
                               local_tests_only => 1,
                               dont_copy_prefs => 1});
 $sa->init(0);
}

sub return_uri_list {
 my $message = shift;
 my $msg = $sa->parse($message); 
 my $pms = Mail::SpamAssassin::PerMsgStatus->new($sa,$msg);
 my @list = ();
 my $parsed = $pms->get_uri_detail_list();
 while (my($uri, $info) = each %{$parsed}) {
  $uri =~ tr/\r//d;
  next unless ($info->{domains});
  push(@list, keys %{$info->{domains}});
 }
 # Remove duplicates
 my(%uris);
 map { $uris{$_}=1; } @list;
 @list = keys %uris;
 $pms->finish();
 $msg->finish();
 $parsed = undef;
 return @list;
}

sub lookup {
 my $uri = shift;
 my @lookup;
 my @listed = ();
 my %uribls = ("multi.surbl.org" => {"64" => "SURBL-JP",
                                     "32" => "SURBL-AB",
                                     "16" => "SURBL-OB",
                                     "8"  => "SURBL-PH",
                                     "4"  => "SURBL-WS",
                                     "2"  => "SURBL-SC"},
               "multi.uribl.com" => {"2"  => "URIBL-BLACK"});
 foreach $uribl (keys %uribls) {
  @lookup = gethostbyname($uri.'.'.$uribl);
  if(scalar(@lookup) != 0) {
   # Positive result
   @uribladdr = unpack('C4',($lookup[4])[0]);
   # Check URIBL return  
   while ( ($k,$v) =  each(%{$uribls{"$uribl"}}) ) {
    if($uribladdr[3] & $k) {
     push(@listed, $v);
    }
   }
  }
 }
 return @listed;
}

sub Log {
 my ($priority, $msg) = @_;
 return 0 unless ($priority =~ /info|err|debug/);
 setlogsock('unix');
 openlog($0,'pid','mail');
 syslog($priority, $msg);
 closelog();
 return 1;
}

sub header_callback {
 my $ctx = shift;
 my $headerf = shift;
 my $headerv = shift;
 my $msgid = $ctx->getsymval('i');
 my $message = $ctx->getpriv();
 ${$message} .= "$headerf: $headerv\r\n";
 $ctx->setpriv($message); 
 return SMFIS_CONTINUE;
}

sub eoh_callback {
 my $ctx = shift;
 my $msgid = $ctx->getsymval('i');
 my $message = $ctx->getpriv();
 ${$message} .= "\r\n";
 $ctx->setpriv($message);
 return SMFIS_CONTINUE;
}

sub body_callback {
 my $ctx = shift;
 my $body_chunk = shift;
 my $len = shift;
 my $msgid = $ctx->getsymval('i');
 my $message = $ctx->getpriv();
 ${$message} .= $body_chunk;
 $ctx->setpriv($message);
 return SMFIS_CONTINUE;
}

sub eom_callback {
 my $ctx = shift;
 my $message = $ctx->getpriv();
 my $msgid = $ctx->getsymval('i');
 my @return = ();
 my $info;
 my @listed = ();
 my @urilist = return_uri_list(${$message});
 foreach $uri (@urilist) {
  @test = lookup($uri);
  if(scalar(@test) != 0) {
   $info = join ", ",@test;
   Log('info',"$msgid: $uri is listed in $info");
   push(@listed, $uri);
  }
 }
 if(scalar(@listed) != 0) {
  $ctx->setpriv(undef);
  $ctx->setreply('553','5.3.0',"Message contains one or more domains that are listed in URI blacklists");
  return SMFIS_REJECT;
 } else {
  $ctx->setpriv(undef);
  return SMFIS_CONTINUE;
 }
}

sub abort_callback {
 my $ctx = shift;
 $ctx->setpriv(undef);
 return SMFIS_CONTINUE;
}

sub close_callback {
 my $ctx = shift;
 $ctx->setpriv(undef);
 return SMFIS_CONTINUE;
}

my %callbacks = ('header'   =>  \&header_callback,
		 'eoh'      =>  \&eoh_callback,
		 'body'     =>  \&body_callback,
		 'eom'      =>  \&eom_callback,
		 'abort'    =>  \&abort_callback,
		 'close'    =>  \&close_callback);
my $milter = new Sendmail::PMilter;
if($milter->auto_setconn($miltername)) {
 $milter->register($miltername, \%callbacks);
 # my $dispatcher = Sendmail::PMilter::prefork_dispatcher(max_children => 10,
 #                                                        max_requests_per_child => 100);
 my $dispatcher = Sendmail::PMilter::postfork_dispatcher();
 $milter->set_dispatcher($dispatcher);
 # Okay - let's go daemonize
 chdir '/';
 umask 0; 
 open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
 open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!";
 open STDERR, '>/dev/null' or die "Can't write to /dev/null: $!";
 defined(my $pid = fork) or die "Cant fork: $!";
 print STDOUT "Started milter-uri, PID $pid\n";
 exit if $pid;
 setsid or die "Can't start a new session: $!";
 # Load SpamAssassin
 init();
 # Start the milter loop
 $milter->main();
}