#!/usr/local/bin/perl

# $Id: fetchmaildotcom,v 1.21 2004/08/08 17:01:24 mackers Exp $
#
# A program to retrieve messages from the webmail interface on
# mail.com/iname.com and deliver to the local SMTP server.

use strict;
use LWP::UserAgent;
use HTTP::Request::Common;
use HTTP::Cookies;
use URI::Escape;
use HTML::Entities;
use Net::SMTP;

# -- global config
my $version = "1.20";
my $smtphost = "localhost";
my $deliver_to = ( getpwuid $< ) [0];
my $configfile = $ENV{HOME} . "/.fetchmaildotcomrc";
my $debug = 0;
my $verbose = 0;
my $dontskiponmissingbody = 0;
my $username_in = "";
my $password_in = "";
my $keep = 0;
my $showhelp = 0;
my $lresp = "";
my $res;
my $cj = HTTP::Cookies->new(ignore_discard => 1);
my %useragentstrs = ("Mozilla/4.0 (compatible; MSIE 5.5; Windows NT 5.0)" => "26",
                     "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" => "68",
                     "Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.0.1) Gecko/20020823 Netscape/7.0" => "72",
                     "Mozilla/4.0 (compatible; MSIE 5.5; Windows NT 5.1)" => "80",
                     "Mozilla/4.0 (compatible; MSIE 6.0; Windows 98)" => "85",
                     "Mozilla/4.0 (compatible; MSIE 5.01; Windows NT 5.0)" => "93",
                     "Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:0.9.4.1) Gecko/20020314 Netscape6/6.2.2" => "95",
                     "Opera/6.05 (Windows 2000; U)  [en]" => "96",
                     "Mozilla/4.0 (compatible; MSIE 5.5; Windows NT 4.0)" => "97",
                     "Opera/7.0 (Windows 2000; U)" => "98",
                     "Mozilla/5.0 (X11; U; SunOS sun4u; en-US; rv:1.1) Gecko/20020827" => "99",
                     "Mozilla/4.0 (compatible; MSIE 5.21; Mac_PowerPC)" => "100"
             );

# -- set webmail settings
my %maildotcomconfig = ( 
	'httpHost' => 'mail02.mail.com',
	'httpLoginURL' => 'http://www.mail.com/scripts/common/proxy.main',
	'httpLoginUsername' => 'login',
	'httpLoginPassword' => 'password',
	'httpLoginInvalidPasswordPattern' => 'Invalid',
	'httpLoginInvalidUsernamePattern' => 'does not exist',
	'httpInboxURL' => 'http://mail02.mail.com/scripts/mail/mailbox.mail',
	'httpReadBaseURL' => 'http://mail02.mail.com/scripts/mail/mesg.mail?folder=INBOX&print=1&mhead=f&.intr=1&msg_uid=',
	'httpEmptyTrashURL' => 'http://mail02.mail.com/scripts/mail/Outblaze.mail?emptytrash&current_folder=Trash',
        'msgIDMatch' => "<td><a href=\"/scripts/mail/mesg.mail.*?msg_uid=([0-9]*)",
	'msgHeaderMatch' => "<b>(.*?): ?</b>(.*?)<br>",
	'msgNextMatch' => "<a HREF=\"http://mail02.mail.com/scripts/mail/mesg.mail\?.did=1&folder=INBOX&order=Newest&mstart=1&mview=a&mhead=f&msg_uid=([0-9]+)\"><b><font size=\"-1\" color=\"#0000FF\">Next",
);

# -- parse command line
while ($_ = shift) {
	if (($_ eq "-k") || ($_ eq "--keep")) {
		$keep = 1;
	} elsif (($_ eq "-K") || ($_ eq "--nokeep")) {
		$keep = 0;
	} elsif (($_ eq "-n") || ($_ eq "--noskip")) {
		$dontskiponmissingbody = 1;
	} elsif (($_ eq "-u") || ($_ eq "--username")) {
		$username_in = shift;
	} elsif (($_ eq "-f") || ($_ eq "--fetchmailrc")) {
		$configfile = shift;
	} elsif (($_ eq "-s") || ($_ eq "--silent")) {
		$verbose = 0;
	} elsif (($_ eq "-S") || ($_ eq "--smtphost")) {
		$smtphost = shift;
	} elsif (($_ eq "-v") || ($_ eq "--verbose")) {
		$verbose = 1;
	} elsif (($_ eq "-d") || ($_ eq "--debug")) {
		$debug = 1;
	} elsif (($_ eq "-V") || ($_ eq "--version")) {
		print "This is fetchmaildotcom release $version\n";
		exit(0);
	} elsif (($_ eq "-h") || ($_ eq "--help")) {
		$showhelp = 1;
	} else {
		$showhelp = 1;
	}
}

# -- read config file
if (open(CONFIGFILE,$configfile)) {
	print STDERR "fetchmaildotcom: using config file \"$configfile\"\n" if ($verbose);
	my $poll = <CONFIGFILE>;
	close (CONFIGFILE);
	if ($poll =~ /^poll\s/i) {
		my @cfoptions = split(/\s+/, $poll);
		shift(@cfoptions);
		while (my $cfoption = shift(@cfoptions)) {
			if ($cfoption =~ /^user/i) {
				$username_in = shift(@cfoptions);
			} elsif ($cfoption =~ /^pass/i) {
				$password_in = shift(@cfoptions);
			} elsif ($cfoption eq "smtphost") {
				$smtphost = shift(@cfoptions);
			} elsif ($cfoption eq "keep") {
				$keep = 1;
			} elsif ($cfoption eq "no") {
				$cfoption = shift(@cfoptions);
				if ($cfoption eq "keep") {
					$keep = 0;
				}
			} else {
				print STDERR "fetchmaildotcom: unknown config file option \"$cfoption\"\n";
			}
		}
	} else {
		print STDERR "fetchmaildotcom: error in config file $configfile line 1\n";
	}
}

# -- if no username, print help message
if (($username_in eq "") || ($showhelp == 1)) {
	print STDERR <<EOF;
Usage: $0 [options]

  A program to retrieve messages from the webmail interface on
  mail.com/iname.com and deliver to the local SMTP server.

  Options are as follows:
  -h, --help        display this message
  -V, --version     display version info
  -s, --silent      work silently (default)
  -v, --verbose     work noisily
  -d, --debug       print entire HTTP dialog
  -u, --username    specifies the email address to use to logon
  -K, --nokeep      delete new messages after retrieval
  -k, --keep        save new messages after retrieval
  -S, --smtphost    deliver here instead of localhost
  -n, --noskip      retrieve messages with no body
  -f, --fetchmailrc the location of the configuration file

EOF
	exit(0);
}

# -- get the password
if ($password_in eq "") {
	system "stty -echo"; # Echo off
	print "Password: "; # Prompt for password
	chomp($password_in = <STDIN>); # Remove newline
	system "stty echo"; # Echo on
	print "\n";
}

# -- encode username and password
my $username = $username_in;
my $password = uri_escape($password_in);
my $username_internal = $username;
$username_internal =~ s/\@/:/g;

# -- create the user agent
my $ua = LWP::UserAgent->new;
$ua->cookie_jar($cj);
$ua->agent(&get_weighted_rand_elem_from_hash(%useragentstrs));

# -- login
my $req = HTTP::Request::Common::POST($maildotcomconfig{'httpLoginURL'},
	[
	  action => 'login',
	  show_frame => 'enter',
	  mail_language => 'us',
	  $maildotcomconfig{'httpLoginUsername'} => $username,
	  $maildotcomconfig{'httpLoginPassword'} => $password,
	]);
$req = $ua->prepare_request($req);
print $req->as_string() if ($debug);
$res = $ua->request($req);
unless ($res->is_success || $res->is_redirect) { print STDERR "fetchmaildotcom: badness, got " . $res->status_line . "\n"; exit(-4); }
$lresp = $res->as_string();
print $lresp if ($debug);
my $pat1 = $maildotcomconfig{'httpLoginInvalidPasswordPattern'};
my $pat2 = $maildotcomconfig{'httpLoginInvalidUsernamePattern'};
if ($lresp =~ /$pat1/i) {
	print STDERR "fetchmaildotcom: invalid password\n";
	exit(-1);
} elsif ($lresp =~ /$pat2/i) {
	print STDERR "fetchmaildotcom: invalid username\n";
	exit(-2);
} else {
	print STDERR "fetchmaildotcom: logged in as $username_in\n" if ($verbose);
}

# -- pick up the cookies on the login redirect
$ua->get($res->header("Location"));

# -- check for new messages
$req = HTTP::Request->new("GET", $maildotcomconfig{'httpInboxURL'} . "?folder=INBOX&read=yes&login=$username_internal&.intr=1");
$req = $ua->prepare_request($req);
print $req->as_string() if ($debug);
$res = $ua->send_request($req);
unless ($res->is_success) { print STDERR "fetchmaildotcom: badness, got " . $res->status_line . " (loc is " . $res->header("Location") . ")\n"; exit(-4); }
$lresp = $res->as_string();
print $lresp if ($debug);
$pat1 = $maildotcomconfig{'msgIDMatch'};
my @messageIDs;
if (@messageIDs = ($lresp =~ /$pat1/igsm)) {
	# found messages
	print STDERR "fetchmaildotcom: found " . scalar(@messageIDs) . " messages\n" if ($verbose);
} else {
	# no mail found
	print STDERR "fetchmaildotcom: no mail found\n" if ($verbose);
	exit(0);
}

# -- retieve all mail
$pat1 = $maildotcomconfig{'msgFromMatch'};
$pat2 = $maildotcomconfig{'msgHeaderMatch'};
my $pat3 = $maildotcomconfig{'msgNextMatch'};
my $count = 0;
foreach my $msgid (@messageIDs) {
	$count++;
	print STDERR "\nfetchmaildotcom ($count): ==== Retrieving mail with ID = $msgid ==== \n" if ($verbose);
	# -- retrieve this message
	$req = HTTP::Request->new("GET",$maildotcomconfig{'httpReadBaseURL'} . $msgid);
	$req = $ua->prepare_request($req);
	print $req->as_string() if ($debug);
	$res = $ua->send_request($req);
	unless ($res->is_success) { print STDERR "fetchmaildotcom: badness, got " . $res->status_line . " (loc is " . $res->header("Location") . ")\n"; exit(-4); }
	$lresp = $res->as_string();
	print $lresp if ($debug);
	# -- parse this message
	my $newmsgid;
	my @headers;
	my $headername = "";
	my $fromfound = 0;
	my $tofound = 0;
	my $content = "";
	my $from = "";
	foreach my $header ($lresp =~ /$pat2/igsm) {
		# decode html entities
		$header = decode_entities($header);
		# clear the leading and trailing whitespace
		$header =~ s/^\s*//sm;
		$header =~ s/\s*$//sm;
		# re-assemble headers
		if ($headername eq "") {
			$fromfound = 1 if ($header =~ /From/i);
			$tofound = 1 if ($header =~ /To/i);
			$headername = $header;
		} else {
			push (@headers, "$headername" . ": " . $header);
			$headername = "";
		}
	}
	# -- check for required fields
	if ($fromfound == 0) {
		print STDERR "fetchmaildotcom ($count): no \"From\" header found -- skipping\n"; 
		next;
	} elsif ($tofound == 0) {
		print STDERR "fetchmaildotcom ($count): no \"To\" header found -- skipping\n"; 
		next;
	}
	# -- print special headers
	foreach my $header (@headers) {
		print STDERR "fetchmaildotcom ($count): $header\n" if (($header =~ /^(From|To|Subject)/i) && ($verbose));
		if ($header =~ /^From:.*?([^"\s<]*@[^"\s>]*)/i) {
			$from = $1;
		}
	}
	# -- get the content
	if ($lresp =~ /<xbody.*?>(.*)<\/xbody>/ism) {
		# is a html mail
		$content = $1;
	} elsif ($lresp =~ /<pre>(.*)<\/pre>/ism) {
		# is plain text
		$content = $1;
	} elsif ($lresp =~ /.*<!-- -->.*?<\/p>\s*<br>(.*)<form>/ism) {
		# is badly formed
		$content = $1;
	} elsif ($lresp =~ /.*<!-- -->.*?<br>\s*<\/p>(.*)<form>/ism) {
		# is badly formed 2
		$content = $1;
	} elsif ($lresp =~ /([^<>]{100,}?)/ism) {
		# last report - match any text node over 100 chars
		$content = $1;
	} elsif ($dontskiponmissingbody != 1) {
		print STDERR "fetchmaildotcom ($count): no mail body found -- skipping\n";
		next;
	}
	# -- print the content length
	print STDERR "fetchmaildotcom ($count): " . length($content) . " bytes in body text\n" if ($verbose);
	# -- send mail using smtp
	my $smtp = Net::SMTP->new($smtphost,
		Hello => $smtphost,
		Timeout => 30,
		#Debug => 1,
		);
	if (!$smtp) {
		print STDERR "fetchmaildtocom: couldn't connect to SMTP server $smtphost\n";
		exit(-6);
	} elsif (!$smtp->verify($deliver_to)) {
		print STDERR "fetchmaildotcom: $deliver_to not valid address\n";
		exit(-5);
	}
	$smtp->mail($from);
	$smtp->recipient($deliver_to);
	$smtp->data();
	$smtp->datasend("Resent-From: $from\n");
	foreach my $header (@headers) {
		$smtp->datasend($header . "\n");
	}
	$smtp->datasend("\n");
	$smtp->datasend($content . "\n");
	$smtp->dataend();
	$smtp->quit();
	# -- delete the message
	if ($keep != 1) {
		print STDERR "fetchmaildotcom ($count): deleting message from server\n" if ($verbose);
		$req = HTTP::Request->new("HEAD", $maildotcomconfig{'httpInboxURL'} . "?folder=INBOX&delete_selected=yes&login=$username_internal&sel_$msgid=ON");
		$req = $ua->prepare_request($req);
		print $req->as_string() if ($debug);
		$res = $ua->send_request($req);
		unless ($res->is_success) { print STDERR "fetchmaildotcom: badness, got " . $res->status_line . "\n"; exit(-4); }
		$lresp = $res->as_string();
		print $lresp if ($debug);
	}
}

# -- empty trash
if (($keep != 1) && ($count > 0)) {
	print STDERR "fetchmaildotcom: emptying trash\n" if ($verbose);
	$req = HTTP::Request->new("GET", $maildotcomconfig{'httpEmptyTrashURL'});
	$req = $ua->prepare_request($req);
	print $req->as_string() if ($debug);
	$res = $ua->send_request($req);
	unless ($res->is_success || $res->is_redirect) { print STDERR "fetchmaildotcom: badness, got " . $res->status_line . "\n"; exit(-4); }
	$lresp = $res->as_string();
	print $lresp if ($debug);
}

# -- sub to get a weighted random element from a hash
sub get_weighted_rand_elem_from_hash {
        my %thehash = @_;
        my @uas = sort { $thehash{$b} <=> $thehash{$a} } keys %thehash;
        my $rand = int(rand(100)) + 1;
        foreach my $uastr (@uas) {
                return $uastr if ($rand > $thehash{$uastr});
        }
        return $_[0];
}