#!/usr/bin/perl -w
#############################################################################
#
#  $RCSfile: wbl,v $
#
#   Do qmail white/blacklist forwarding.
#  Original Author: Caskey Dickson <caskey@technocage.com> 2002-10-28
#  Copyright 2002 TechnoCage, Inc.  All Rights Reserved
#  $Id: wbl,v 1.4 2003/02/18 07:35:13 caskey Exp $
#
#   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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
#
#############################################################################

use strict;

##  Read in a message from standard in.  If the From: field is in our
##  whitelist, then forward the message to $ARGV[0] and halt processing
##  of the .qmail file.  Otherwise, let Qmail continue processing the
##  .qmail file as normal.  If the message is in the blacklist, forward
##  the mail to $ARGV[1] and halt processing.

my($debug) = 0;

my($FORWARD) = '/var/qmail/bin/forward';
$debug && ($FORWARD = '/bin/cat');

my($QMOkContinue, $QMOkStop, $QMSoftError, $QMHardError) = (0, 99, 111, 100);

my($whiteRecipient, $blackRecipient) = @ARGV;
&QMFail($QMSoftError, "Misconfiguration in delivery.\n") unless 
    ($whiteRecipient && $blackRecipient);

# Read in the message.
my(@message) = <STDIN>;

# Extract the from header
my($from) = &extractFrom(@message);

$debug && print STDERR "Checking whitelist for '$from'\n";

my $wbScore = &getWBScore($from);

# If header matches a regex in the whitelist...
if($wbScore > 0) {
  $debug && print STDERR "'$from' in whitelist\n";
  &forward($whiteRecipient);
} elsif ($wbScore < 0) {
  $debug && print STDERR "'$from' in blacklist\n";
  &forward($blackRecipient);
} else {
  $debug && print STDERR "Not in either list.\n";
  exit $QMOkContinue;
}
exit $QMOkContinue;

sub extractFrom {
  my(@message) = @_;
  foreach(@message) {
    last if (m/^$/);
    if (m/^from: (.*)$/i) {
      return $1;
    }
  }
  return "";
}

sub forward {
  my($to, $result) = @_;
  $result = $QMOkStop unless $result;
  open( FORWARD, "|$FORWARD $to") || &QMFail($QMSoftError, "Unable to forward to mailbox\n");
  foreach(@message) {
    print FORWARD $_;
  }
  close(FORWARD);
  exit($result);
}

sub getWBScore {
  my($find) = @_;
  open( WBL, "<$ENV{'HOME'}/.wbl") || &QMFail($QMSoftError, "WBL not found in $ENV{'HOME'}!\n");
  foreach(<WBL>) {
    next if m/^\s*#/;
    s/^\s*//;
    s/\s*$//;
    if( s/^\s*-\s*// ) {
      $debug && print STDERR "Checking blacklist: $_\n";
      if($find =~ m/$_/i) {
        close WBL;
        return -1;
      }
    } elsif( s/^\s*\+?\s*// ) {
      $debug && print STDERR "Checking whitelist: $_\n";
      if($find =~ m/$_/) {
        close WBL;
        return +1;
      }
    }
  }
  close WBL;
  return 0;
}

sub QMFail {
  my($code, $message) = @_;
  print STDERR $message;
  exit $code;
}