#!/usr/bin/perl
#
# Munged address filtering program
# Copyright 1999 M-J. Dominus (mjd-perl-addrmunge@plover.com)
# You may distribute this file under the terms of the GNU 
# General Public License, version 1, or, at your option,
# any later version.
#


%expired = ('ill+bgeejet' => 1, 
	    'inj+g5udq4' => 1,
	    'in7+butpocm' => 1,
	    'iqk+dm9gac' => 1,
            'it7+bwdd2gk' => 1,
            'ium+bwb04e3' => 1,
            'ius+rspy04' => 1,
            'ivb+bvswizz' => 1,
            'iu9+bw5g9sd' => 1,
            'iyf+bw7jlnu' => 1,
            'iv9+bv46hmd' => 1,
            'iv3+rr8qvg' => 1,
            'izz+bw5g9s9' => 1,
            'iws+bx9zvct' => 1,
            'i0q+r11opo' => 1,
	   );

%use_date = ('thisweek' => 1,
	     'perlcom' => 1, 
	     );

open STDERR, ">> /tmp/idfilter";
print STDERR "-----------------------$$\n";
print STDERR "Starting: from $ENV{SENDER} to $ENV{LOCAL}\n";

open LOG, ">> /tmp/idflog" or defer("Couldn't write log file: $!; deferring");

$MAILER = '/var/qmail/bin/qmail-inject';
$HOME = $ENV{HOME};
$USER = $ENV{USER};
%Reject_File = (polite_expired => "$HOME/lib/mail.pexpired",
		expired => "$HOME/lib/mail.expired",
		IDless => "$HOME/lib/mail.idless",
		);

$SUBJLOG = '/tmp/idfsubject';
my $recipient = $LOCAL = $ENV{LOCAL};
my $delivery = $recipient;
$ME = "$LOCAL-discard\@plover.com";

%recipinfo = ('mjd-perl-template' => 'recipinfo.template');

{
  local $/ = "";
  $HEADER = $MESSAGE = <>;
  ($SUBJECT) = $HEADER =~ /^Subject:\s+(.*)$/m;
  local $/ = undef;
  $BODY = <>;
  $MESSAGE .= $BODY;
}

if ($delivery =~ s/-(\w+)-(\d{6})\+?$// && $use_date{$1}) {
  my ($ad_year, $ad_month) = unpack "A4 A2", $2;
  my ($y, $m) = (localtime)[5,4];
  my $mno = $m+1 + ($y+1900)*12;
  my $ad_mno = $ad_month + $ad_year*12;
  if ($ad_mno < $mno - 2) {
    print LOG "Delivery to $recipient (expired ID $ID) rejected -- too old.\n";
    reject('polite_expired');
  } else {
    print LOG "Delivery to $recipient (good ID $ID) allowed.\n";
#    allow($delivery . '-deliver');
    allow('mjd-deliver@plover.com');
  }
} elsif ($delivery =~ /-discard$/) {
  exit 0;
} elsif ($delivery =~ /-(ok|deliver)$/) {
  print LOG "Delivery to $recipient (special-case accept) allowed.\n";
  allow($USER . '-deliver');
} elsif ($delivery =~ s/-id-([\w\+]+)$//) {
  my $ID = $1;
  $ID =~ s/\+$//;
  warn "Recognized ID $ID in address $recipient -> $delivery\n";
  if ($expired{$ID}) {
    print LOG "Delivery to $recipient (expired ID $ID) rejected.\n";
    reject('expired');
  } else {
    print LOG "Delivery to $recipient (good ID $ID) allowed.\n";
    allow($delivery . '-deliver');
  }
} elsif ($delivery =~ /[-+]$/) {
  print LOG "Delivery to $recipient (special-case accept) allowed.\n";
  allow($USER . '-deliver');
} else {
  print LOG "Delivery to $recipient (missing ID) rejected.\n";
  reject('IDless', Recipient => $recipient);
}
close LOG;

sub allow {
  my ($delivery) = @_;
  warn "Accepting $recipient for $delivery.\n";
  forward($delivery);
  exit 0;
}

sub forward {
  my ($delivery) = @_;
  local *FORWARD;
  warn "Forwarding to $delivery.\n";
  unless (open(FORWARD, "| /var/qmail/bin/forward $delivery")) {
    &defer("Couldn't run forward to forward to $delivery.\n");
  }
  print FORWARD $MESSAGE;
}

sub reject {
  my $reason = shift;
  my %opt = @_;
  my $subject = $opt{Subject} || "Sorry, that address ($LOCAL) has expired.";
  my $details = $opt{Details};
  my $orig_recip = $opt{Recipient};

  warn "Rejecting: Reason is `$reason'.\n";
  warn "Details: $details.\n" if defined $details;

  &forward("$USER-reject");

  if (open (S, ">> $SUBJLOG")) {
    my ($y,$m,$d) = (localtime)[5,4,3];
    my $date = sprintf "%04d%02d%02d", $y+1900, $m+1, $d;
    print S $date, " ", $SUBJECT, "\n";
    close S;
  } else {
    print STDERR "Couldn't append to subject log file `$SUBJLOG': $!.\n";
  }

  my $recip = $H{'Reply-To'} || $H{'From'} || $ENV{SENDER};
  unless (defined $recip) {
    warn "No recipient address could be found!\n";
    exit 0;
  }

  my $replyfile = $Reject_File{$reason};
  unless($replyfile) {
    &defer("No reply file was defined for reason `$reason'.\n");
  }
  unless (open REPLY, "< $replyfile") {
    &defer("Couldn't open  reply file `$replyfile' for reason `$reason': $!\n");
  }

  if ($ARGV{NoReply} || $H{Precedence} =~ /^(bulk|junk)$/i
     || $recip =~ /^http:/) {
    print STDERR "Suppressing reply to `$recip'\n";
    exit 0;
  }

  &inject($ME);
  print STDERR "Injecting mail to `$recip'.\n";
  print INJECT <<EOM;
From: $USER\'s automatic filtering service <$ME>
To: $recip
Subject: $subject
X-Rejection-Type: $reason
Precedence: bulk

EOM
  while (<REPLY>) {
    s/(\$[a-zA-Z_]\w*)/$1/ee;
    print INJECT;
  }

  if ($orig_recip && exists $recipinfo{$orig_recip}) {
    local *RI;
    if (open RI, "< $HOME/lib/$recipinfo{$orig_recip}") {
      print INJECT "\n\n---- Information that may be relevant to your message\n\n";
      print INJECT while <RI>;
      print INJECT "\n---- End of possibly relevant information\n\n";
    } else { 
      print STDERR "Couldn't open recipinfo for $orig_recip: $recipinfo{$orig_recip} $!.\n";
    }
  } else {
    print STDERR "Not going to get any recipinfo for $orig_recip.\n";
  }

  print INJECT "---- Begin returned message\n";
  print INJECT $HEADER;
  foreach $line (split(/^/, $BODY)) {
    $line =~ s/^/- / if $line =~ /^-/;
    print INJECT $line;
  }
  print INJECT "---- End returned message\n";

  close INJECT;

  exit 0;
}

sub defer {
  my $msg = shift;
  require Carp;
  Carp::carp $msg;
  if (open (TMP, "> /tmp/MESSAGE")) {
    print TMP $MESSAGE;
  }
  exit 111;
}

sub inject {
  my $from = shift;
  my $fromarg = defined($from) ? ($from eq '' ? '""' : "'-f$from'") : "";
#  warn "Injecting: from=.$from.; fromarg=.$fromarg.\n";
  unless (open(INJECT, "| /var/qmail/bin/qmail-inject $fromarg")) {
    &defer("Oh no!  Couldn't run qmail-inject: $! . Deferring...\n");
  }
}