#!/usr/bin/perl -wT

use strict;
use Fcntl;
use Digest::MD5;
use IO::Handle;
use IPC::Open3;
use Time::Local;
use File::Sync qw(fsync sync);
use lib ".";
use GpgEzmlm;

my $configfile = "config";
my %config = ();

$ENV{PATH} = "/bin:/usr/bin";
$ENV{ENV} = "";

#cookie generates a hash given a timestamp, a secret, etc. This infomation
#is used to generate and check confirmation strings. This is _not_ the
#same hash algorithm used by ezmlm, but since the strings are ephemeral,
#so long as I'm self consistent, it shouldn't matter.
#type is either "s" for subscribe or "u" for unsubscribe
#target is email addr

sub cookie {
  my %charhash = ( 'a'=>'a', 'b'=>'b', 'c'=>'c', 'd'=>'d', 'e'=>'e', 'f'=>'f',
		   '0'=>'g', '1'=>'h', '2'=>'i', '3'=>'j', '4'=>'k', '5'=>'l',
		   '6'=>'m', '7'=>'n', '8'=>'o', '9'=>'p' );
  my $key = shift;
  my $time = shift;
  my $target = shift;
  my $type = shift;
  my $cookie;

  my $context = Digest::MD5->new;
  $context->add($key);
  $context->add($time);
  $context->add($target);
  $context->add($type);

  my $digest = $context->hexdigest;

  my @characters = split //, $digest;
  for my $i (0..19) {
    $cookie .= $charhash{($characters[$i])};
  }
  $cookie;
}

#maillog writes events to the log file.

sub maillog {
  my $event = shift;
  my $addr = shift;
  
  open FD, ">>Log" or return;
  print FD time();
  print FD " $event $addr\n";
  close FD;
}

#hashok checks to see if the time given is within 1000000 seconds of now,
#and if indeed the hash given is valid. ezmlm keeps no state on 
#(un)subscription confirmations. the assumption is, if you can provide a
#valid hash with a valid timestamp, I must have sent that hash to you,
#because I need the secret key to produce the hash.

sub hashok {
  my $action = shift;
  my $key = shift;
  my $target = shift;
  
  my $x = $action;
  $x =~ s/^-(\w)\w\.//;
  my $type = $1;
  $x =~ /^(\d+)/;
  my $u = $1;
  if (($u > time) or ($u < time - 1000000)) {
    return 0;
  }

  my $cookie = cookie($key, $u, $target, $type);
  
  if ($x =~ /$cookie/) {
    return 1;
  }
  return 0;
}    

# A comment about the below. gpgimport is a bit of a kludgey hack. The basic
# premise is we want to avoid the attack wherein someone subscribes to the
# list as <foo@bar.com> but provides a key for <tmacd@synacklabs.net>,
# hypothetically. The Right Way would be to read the key directly, I 
# suppose, but I'll be damned if I implement a key decoder for this.
#
# So I filter by sending the keys off to key purgatory, also known as
# a tmp dir. I then extract only the known acknowledged addr from
# purgatory, and hopefully we're good to go.
#
# Someone feel free to rewrite this to read the key directly. ^_^

sub gpgimport {
  my $gpgkey = shift;
  my $addr = shift;
  my $configRef = shift;
  my $error;
  my $empty = "";

  my $tmpgpg = "$$configRef{gpg} --homedir $$configRef{tempDir}";
  my $gpg = "$$configRef{gpg} --homedir $$configRef{keyDir}";
  
  unlink ("$$configRef{tempDir}/pubring.gpg");
  my $cleansedkey;
  my $pid  = runcmd("$tmpgpg --no-tty --import",
	 \$gpgkey,
	 \$empty,
	 \$error);
  waitpid $pid, 0;
  
  $pid  = runcmd("$tmpgpg --no-tty --export -a $addr\n",
		 \$empty,
		 \$cleansedkey,
		 \$error);
  
  $pid = runcmd("$gpg --no-tty --import",
		\$cleansedkey,
		\$empty,
		\$error);
}

#begin program proper here.  

my $sender;
my $taintsender;
my $host;
my $tainthost;
my $local;
my $taintlocal;
my $key;
my $action;

my $mailinglist;
my $inhost;
my $inlocal;
my $outhost;
my $outlocal;
my $when = time;


if ($ENV{SENDER}) {
  $taintsender = $ENV{SENDER};
} else {
  mydie(100, "SENDER not set\n");
}
if ($ENV{LOCAL}) {
  $taintlocal = $ENV{LOCAL};
} else {
  mydie(100,"LOCAL not set\n");
}
if ($ENV{HOST}) {
  $tainthost = $ENV{HOST};
} else {
  mydie(100,"HOST not set\n");
}

if((!($taintsender=~/\S+/)) || ($taintsender =~ /\#\@\[\]/)) {
  mydie(100,"I don't reply to bounce messages (#5.7.2)\n");
}
if(!($taintsender=~/\@/)) {
  mydie(100,"I don't reply to senders without host names (#5.7.2)\n");
}

# The following may be overly restrictive. Please let me know what I
# need to add

if ($taintsender =~ /([a-zA-Z0-9\@\+\.\-\_]*)/) {
  $sender = $1;
}

if ($tainthost =~ /([a-zA-Z0-9\@\+\.\-\_]*)/) {
  $host = $1;
}

if ($taintlocal =~ /([a-zA-Z0-9\@\+\.\-\_]*)/) {
  $local = $1;
}


my $dir;

my $taintdir = shift;
if ($taintdir =~ /(\S+)/) {
  $dir = $1;
} else {
  mydie(100,"$0: usage: $0 dir\n");
}

chdir "$dir" or mydie(111,"unable to switch to $dir: $!\n");

readConfig("$configfile", \%config);

if (!(-f "key")) {
  mydie(100, "$dir/key does not exist\n");
}

open KEY, "<key" or mydie(111, "unable to read $dir/key: $!\n");
$key = <KEY>;
close(KEY);

open MAILINGLIST, "<mailinglist" or mydie(111, "unable to open $dir/mailinglist: $!\n");
$mailinglist = <MAILINGLIST>;
chomp $mailinglist;
close(MAILINGLIST);
open INHOST, "<inhost" or mydie(111, "unable to open $dir/inhost: $!\n");
$inhost = <INHOST>;
chomp $inhost;
close(INHOST);
open INLOCAL, "<inlocal" or mydie(111, "unable to open $dir/inlocal: $!\n");
$inlocal = <INLOCAL>;
chomp $inlocal;
close(INLOCAL);
open OUTHOST, "<outhost" or mydie(111, "unable to open $dir/outhost: $!\n");
$outhost = <OUTHOST>;
chomp $outhost;
close(OUTHOST);
open OUTLOCAL, "<outlocal" or mydie(111, "unable to open $dir/outlocal: $!\n");
$outlocal = <OUTLOCAL>;
chomp $outlocal;
close(OUTLOCAL);

if (!($inhost eq $host)) {
  mydie(100,"I do not accept messages at this address (#5.1.1)\n");
}
if(!($local =~ /$inlocal/)) {
  mydie(100,"I do not accept messages at this address (#5.1.1)\n");
}

$action = $local;
$action =~ s/$inlocal//;

my $line;
if (!(-f "public")) {
  mydie(100, "sorry, I've been told to reject all requests (#5.7.2)\n");
}

if(!(-f "public")) {
  mydie(100, "sorry, I've been told to reject all requests (#5.7.2)\n");
}
open PUBLIC, "<public" or mydie(111,"unable to read $dir/public: $!\n");
close (PUBLIC);

my $target = $sender;

my $message;

if ($action =~ /^-get\.(\d+)/) {
  use integer;
  my $startmsgnum = $1;
  my $endmsgnum = $1;
  if ($action =~ /^-get\.\d+-(\d+)/) {
    $endmsgnum = $1;
  }
  for(my $i = int($startmsgnum); $i <= int($endmsgnum); $i++) {
    my $archived = $i;
    my @archivedMessage = ();
    my $dirnum = $i/100;
    my $msgnum;
    if(($i%100) < 10) {
      $msgnum = "0".($i%100);
    } else {
      $msgnum = $i%100;
    }
    if(open MESSAGE, "<archive/$dirnum/$msgnum") {
      while(defined(my $line = <MESSAGE>)) {
	push @archivedMessage, $line;
      }
       $message = prepare(\@archivedMessage, \%config, $archived, $sender);
      mail("$config{qmailDir}/qmail-queue", $message, 
	   "$outlocal-help\@$outhost", $sender);
    } else {
      mydie(100, "Requested archive message $i does not exist\n");
    }
  }
  exit();
}

$message .= "Mailing-List: $mailinglist\n";

my $rfc822date = rfc822date();

$message .= "Date: $rfc822date\n";
$message .= "Message-ID: <$when.$$.ezmlm\@$outhost>\n";
$message .= "From: $outlocal-help\@$outhost\n";
$message .= "To: $target\n";

my $flaghashok = 1;
my $flagconfirm = 0;
if($action =~ /^-(s)c\./) {
  $flaghashok = hashok($action, $key, $target);
}
if($action =~ /^-(u)c\./) {
  $flaghashok = hashok($action, $key, $target);
}
if($action =~ /^-(s)ubscribe$/) {
  $flagconfirm = 1;
}
if($action =~ /^-(u)nsubscribe$/) {
  $flagconfirm = 1;
}
if (!($flaghashok)) { $flagconfirm = 1; }

my $confirm;

if ($flagconfirm) {
  my $type = $1;
  my $cookie = cookie($key, $when, $target, $type);
  $target =~ /(\S+)\@(\S+)/;
  $confirm .= "$outlocal-$type";
  $confirm .= "c.$when.$cookie-$1";
  $confirm .= "=$2\@$outhost";
  $message .= "Reply-To: $confirm\n";
}

$message .= "Subject: ezmlm response\n";
my $mydtline = "Delivered-To: responder for $outlocal\@$outhost\n\n";
$message .= $mydtline;

my $flaggoodfield = 0;
my $gpgkey;
my $flaginkey = 0;
my $messagecp;

while (<STDIN>) {
  my $line = $_;
  $messagecp .= $line;
  if ($flaginkey) {
    if($line =~ /(^[\w\s\/\+\=\-\:\.\(\)]+)$/) {
      $gpgkey .= $line;
    }
  }
  if (($line =~ /-----BEGIN PGP PUBLIC KEY BLOCK-----/) && (!($flaginkey))) {
    $gpgkey .= $line;
    $flaginkey = 1;
  }
  if ($line =~ /-----END PGP MESSAGE-----/) {
    $flaginkey = 0;
  }
  if(!($line =~ /^\s/)) {
    $flaggoodfield = 0;
    if($line =~ /^mailing-list:/) {
      mydie(100, "incoming message has Mailing-List (#5.7.2)\n");
    }
    if ($line =~ /^$mydtline/) {
      mydie(100, "this message is kinda looping: it already has my Delivered-To line (#5.4.6): $mydtline");
    }
    if (($line =~ /^delivered-to:/) or ($line =~ /^received:/)) {
      $flaggoodfield = 1;
    }
  }
  if($flaggoodfield) {
    $message .= $line;
  }
}
copy("text/top", \$message, 0, \%config, $confirm, $target);
if ($action =~ /^-subscribe$/) {
  copy("text/sub-confirm", \$message, 0, \%config, $confirm, $target);
} elsif ($action =~ /^-unsubscribe$/) {
  copy("text/unsub-confirm", \$message, 0, \%config, $confirm, $target);
} elsif ($action =~ /^-sc\./) {
  if($flaghashok) {
    if($config{allowKeySubmission}) {
      gpgimport($gpgkey, $target, \%config);
    }
    if (subscribe($target, 1) > 0) {
      maillog("+",$target);
      copy("text/sub-ok", \$message, 0, \%config, $confirm, $target);
    } else {
      copy("text/sub-nop", \$message, 0, \%config, $confirm, $target);
    }
  } else {
    copy("text/sub-bad", \$message, 0, \%config, $confirm, $target);
  }
} elsif ($action =~ /^-uc\./) {
  if($flaghashok) {
    if (subscribe($target, 0) > 0) {
      maillog("-", $target);
      copy("text/unsub-ok", \$message, 0, \%config, $confirm, $target);
    } else {
      copy("text/unsub-nop", \$message, 0, \%config, $confirm, $target);
    }
  } else {
    copy("text/unsub-bad", \$message, 0, \%config, $confirm, $target);
  }
} else {
  copy("text/help", \$message, 0, \%config, $confirm, $target);
}
copy("text/bottom", \$message, 0, \%config, $confirm, $target);

$message .= "Return-Path: <$sender>\n";
$message .= $messagecp;

mail("$config{qmailDir}/qmail-queue", $message, "$outlocal-return-\@$outhost", "$target");