#! perl -w
#
# This script processes a file in Berkeley mailbox format and locates
# EarthLink Challenge-Response URLs (there's a bunch of other domains
# that use the same system besides earthlink.com). It then automatically
# fetches the challenge webpage and constructs a POST response. If the
# CAPTCHA on the page is a repeat of a known value it will put up a
# little Tk widget for human assistance. If, as will be usual after a
# while, the CAPTCHA is a known one, the response will be sent without
# further human assistance.
#
# Written December 2005  Richard Clayton  richard AT highwayman.com
# Last edit 12 FEB 2006
#
# This script may be freely used and adapted by anyone who is not
# going to use it to send spam. It would be polite to leave my name
# upon it as the initial author :)
#
# If you are unable to make the script work for you or you do not understand
# what environment it needs to operate or you have any other problems
# with it then please discard it and get on with the rest of your life.
# I have zero interest in holding your hand in order to make it work!
#
# Note also that you use this script at your own risk. It is undoubtedly
# possible to craft special emails which -- when this script is run -- will
# cause your machine to visit websites and send information to them that
# you will later regret. If you do not understand how to prevent this
# occurring then once again this script is not suitable for your use.
#
# Use at your own risk. No warranty of any kind is made about this script.
#

use strict;
use Fcntl;
use LWP::UserAgent;
use HTTP::Request::Common;
use Tk;
use Tk::JPEG;
use Tk::Entry;
use MD5;

my $TRUE = 1;
my $FALSE = 0;

my $ua = LWP::UserAgent->new;
push @{ $ua->requests_redirectable }, 'POST';

my $mw;
my $text;
my $entry;
my $server;

die "usage: perl earthlink.pl mboxfile...\n" if ($#ARGV < 0);

my $history = "history";  # history directory

open (LOG,">>logfile.txt") or die "Cannot open LOG file 'logfile.txt'";

my ($s,$m,$h,$D,$M,$Y,$wd,$yd,$dst) = localtime(time);
my $now = sprintf("%4d-%02d-%02d %02d:%02d:%02d", $Y+1900, $M+1, $D, $h, $m, $s);

#====================
# process our history
#====================

my $md5 = new MD5;

my %hashes;
my $maxIMAGE = 0;

if (open (HIST,"<$history\/history.txt"))
{
   while (<HIST>)
   {
      if (/^File=(\d{8})\.jpg, MD5=([0-9a-f]{32}), Text=(\w+|\?\?\?)$/)
      {
         $maxIMAGE = $1 if ($1 > $maxIMAGE);

         $hashes{$2} = $3;
      }
      else
      {
         die "Bad HIST file line: '$_'";
      }
   }

   close HIST;
}
else
{
   print STDERR "Failed to open existing HISTORY file $history\/history\n";

   unless (-e ($history))
   {
      mkdir($history) or die "Failed to create HISTORY directory: $history\\\n";
   }

   die "HISTORY directory '$history' is not in fact a directory\n" unless -d $history;
}

#===============
# process emails
#===============

open (HIST,">>$history\/history.txt") or die "Cannot open HISTORY file '$history\/history.txt'";
open (RESULTS,">>$history\/results.txt") or die "Cannot open RESULTS file '$history\/results.txt'";

foreach (@ARGV)
{
   my $argument = $_;

   my (@filelist) = glob($argument);

   foreach my $filename (@filelist)
   {
      open(EMAIL, "$filename") || die "Unable to open $filename: $!\n";

      print STDERR "\nProcessing $filename\n";

      emailparse();

      close(EMAIL);
   }
}

close RESULTS;
close HIST;
close EMAIL;

close LOG;

#end of MAIN

#=============
sub emailparse
#=============
{
   my $done = $FALSE;

   while (<EMAIL>)
   {
      if (/^From /)
      {
         $done = $FALSE;
      }
      elsif (/(https:\/\/webmail.[\.\w]+)(\/wam\/addme?.*?&id=\w*)$/)
      {
         unless ($done)
         {
            $server = $1;
            respond($2);
         }

         $done = $TRUE;
      }
   }
}

#==========
sub respond
#==========
{
   my ($details) = @_;

   print "Trying $details\n";

   my $result = $ua->request(GET $server.$details);

   if ($result->is_success)
   {
      my $ok = ($result->content =~ /ERROR: Unable to process Allowed Sender request/);

      if ($ok)
      {
         print "Too late to try this one\n";
         print RESULTS "$now TOO LATE: $server $details\n";
         return;
      }

      $ok = ($result->content =~ /(\/wam\/verificationImageServlet\?input=.*?\&x=[\-\d]+\")/);
      my $image = $1;

      unless ($ok)
      {
         print "Failed to locate image prompt\n";
         print LOG $result->content;
         print RESULTS "$now BAD PAGE: $server $details\n";
         return;
      }

      my $ires = $ua->request(GET $server.$image);

      if ($ires->is_success)
      {
         print "Image retrieved OK\n";

         my $hex = $md5->hexhash($ires->content);

         $text = $hashes{$hex};

         $text = "???" unless $text;

         if ($text eq "???")
         {
            my $imageFile = sprintf("%08d.jpg", ++$maxIMAGE);

            if (sysopen (IMAGE, "$history\/$imageFile", O_BINARY | O_WRONLY | O_CREAT))
            {
               print IMAGE $ires->content;
               close IMAGE;

               interact("$history\/$imageFile");

               print HIST "File=$imageFile, MD5=$hex, Text=$text\n";

               die "Failed to provide a string\n" if ($text eq "???");

               $hashes{$hex} = $text;
            }
            else
            {
               die ("Failed to open $imageFile, $!");
            }
         }
         else
         {
            print "Already know text is $text\n";
         }
      }
      else
      {
         print "Failed to retrieve Image\n";
         print $ires->status_line, "\n";

         print RESULTS "$now NO IMAGE $server $details $image\n";
         return;
      }

      $ok = $result->content =~ /type=hidden name="id" value="(.*?)"/;
      my $id = $1;

      $ok .= $result->content =~ /type=hidden name="a" value="(.*?)"/;
      my $a = $1;

      $ok .= $result->content =~ /type=hidden name="from_email" value="(.*?)"/;
      my $from = $1;

      $ok .= $result->content =~ /type=hidden name="subject" value="(.*?)"/;
      my $subject = $1;

      if (!$ok)
      {
         print "Failed to find all components of form\n";
         print LOG $result->content;

         print RESULTS "$now BAD FORM $server $details $image\n";
         return;
      }

      submit($id, $a, $from, $subject, $details, $image);
   }
   else
   {
      print "Failed to get challenge page\n";
      print $result->status_line, "\n";

      print RESULTS "$now NO PAGE $server $details";
   }
}

#=========
sub submit
#=========
{
   my ($id, $a, $from, $subject, $details, $image) = @_;

   my $result = $ua->request(
                  POST $server.'/wam/addmeSubmit',
                  [
                     multi      => 'no',
                     id         => $id,
                     a          => $a,
                     from_email => $from,
                     subject    => $subject,
                     first      => 'Richard',
                     middle     => '',
                     last       => 'Clayton',
                     reason     => 'Your tedious challenge-response system sends junk to me whenever you receive spam. Turn it off!',
                     challenge  => $text
                  ]);

   if ($result->is_success)
   {
      if ($result->content =~ /chooses to allow email from your address, the message\(s\) that have been intercepted will be delivered immediately/)
      {
         print "Challenge Accepted OK\n";

         print RESULTS "$now OK $server $details $image $text\n";
      }
      else
      {
         print "Problem with $id:$a\n";

         print LOG $result->content;

         print RESULTS "$now FAIL $server $details $image $text\n";
      }
   }
   else
   {
      print $result->status_line, "\n";

      print RESULTS "$now DIED $server $details $image $text\n";
   }
}

#===========
sub interact
#===========
{
   my ($file) = @_;

   $mw = MainWindow->new();

   my $image = $mw->Photo(-file => $file, -format => "jpeg" );

   $mw->Label(-image => $image)->pack(-expand => 1, -fill => 'both');

   $entry = $mw->Entry(-width => 20, -takefocus=>1)->pack;

   $mw->Button(-text => 'Done', -command => \&quitCommand)->pack;

   MainLoop;
}

#==============
sub quitCommand
#==============
{
   $text = $entry->get();

   $mw->destroy;
}

#ends