#!/usr/local/bin/perl -w
# $Id: wmailr.pl,v 1.26 2004/03/20 13:45:55 mas Exp $
#
# wmailr.pl: Read mail from an IMAP mailbox
# Copyright 2002-2004 Marc André Selig.
# All rights reserved.

use strict;
use CGI;
use Net::IMAP::Simple;
use MIME::QuotedPrint;
use Crypt::RC4;

### Configuration
my $thisurl = "wmailr.pl";
my $indexchunksize = 5;
my $msgchunksize = 950;
my $refreshtime = "300";	# [seconds]
my $arcfolder = "Archive";
my $trashfolder = "Trash";
my $logfile = undef;
my $passphrase = "put something else here";

$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin';
$ENV{'CDPATH'} = '';
$ENV{'BASH_ENV'} = '';


##### Parse CGI parameters ####################################################

my $q = new CGI;
my $params = $q->Vars;

my $user = my $pass = my $host = my $folder = "";

# The cookie is read first so that explicit inputs can override the cookie.
my $authcookie = undef;
if (defined $params->{auth}) {
	$authcookie = $params->{auth};
} elsif (defined $q->cookie('auth')) {
	$authcookie = $q->cookie('auth');
} else {
	$authcookie = "";
}
if (RC4($passphrase, $authcookie) =~
  /^([-.a-zA-Z0-9]+):([-.a-zA-Z0-9]+):([-.a-zA-Z0-9]+):([a-zA-Z]*)$/) {
	$user = $1;  $pass = $2;  $host = $3;  $folder = $4;
}

$host = parseparam($params->{host}, '^[-.a-zA-Z0-9]+$', $host);
$user = parseparam($params->{user}, '^[-.@a-zA-Z0-9]+$', $user);
$pass = parseparam($params->{pass}, '^[-.@a-zA-Z0-9]+$', $pass);
$folder = parseparam($params->{folder}, '^[a-zA-Z0-9]+$', $folder);

# Set user name to "0" to force relogin
if ($user eq "0") {
	$host = $user = $pass = "";
}
# Set folder name to a number to force folder selection
if ($folder =~ /^[0-9]+$/) {
	$folder = "";
}

my $chunk = parseparam($params->{chunk}, '^[0-9]+$', 0);
my $msg = parseparam($params->{msg}, '^[0-9]+$', "");
my $delmsg = parseparam($params->{del}, '^[0-9]+$', "");
my $arcmsg = parseparam($params->{arc}, '^[0-9]+$', "");
my $delfolder = parseparam($params->{delfolder}, '^1$', "");

if (my $mc = parseparam($params->{msgchunk}, '^[0-9]+-[0-9]+$', undef)) {
	$mc =~ /^(.+)-(.+)$/;
	$msg = $1;
	$chunk = $2;
}

open (LOG, ">>$logfile") if defined $logfile;
print LOG "wmailr at " . localtime() . " $user@$host/$folder:$msg, " .
    "chunk:$chunk, del:$delmsg, arc:$arcmsg\n" if defined $logfile;


##### functions ###############################################################

sub parseparam {
	my ($source, $pattern, $default) = @_;

	if ((defined $source) and ($source =~ /$pattern/)) {
		return $source;
	} else {
		return $default;
	}
}

sub wmltitle {
	my ($id, $title, $setcookie, $refresh, $timer) = @_;

	if ($setcookie) {
		print $q->header(-type=>'text/vnd.wap.wml',
				 -Cache_control=>'no-cache',
				 -expires=>'now',
				 -Pragma=>'no-cache',
				 -cookie=>$q->cookie(-name=>'auth',
					-value=>RC4($passphrase,
						"$user:$pass:$host:$folder"))
				);
	} else {
		print $q->header(-type=>'text/vnd.wap.wml',
				 -Cache_control=>'no-cache',
				 -expires=>'now',
				 -Pragma=>'no-cache'
				);
	}

	print	'<?xml version="1.0"?>'."\n",
		'<!DOCTYPE wml PUBLIC "-//WAPFORUM//DTD WML 1.1//EN" "http://www.wapforum.org/DTD/wml_1.1.xml">',
		"<wml>";

	print "<card id=\"$id\" title=\"$title\"";
	if ($refresh) {
		print " ontimer=\"$refresh\"><timer value=\"$timer" . "0\"/";
		# timer resolution in WAP is 1/10 second
	}
	print "><p>";

	return 1;
}

sub boxlogin {
	my $srv = new Net::IMAP::Simple($host);
	$srv->login($user, $pass);
	my $count = $srv->select($folder);
	return ($srv, $count);
}

sub wmlclose {
	my $srv = shift;
	print "</p></card></wml>\n";
	$srv->quit() if $srv;
}

sub wmlencode {
	my $target = shift;

	$target =~ s/&/&amp;/g;
	$target =~ s/</&lt;/g;
	$target =~ s/>/&gt;/g;
	$target =~ s/\"/&quot;/g;
	$target =~ s/\r?\n\r?/<br\/>/sg;
	$target =~ s/([äöüÄÖÜßé])/'&#'.ord($1).';'/eg;
	$target =~ s/\$/\$\$/g;
	$target =~ tr/ \n!-~//cd;

	return $target;
}

sub foldermove {
	my ($msg, $target) = @_;
	my ($srv, $count) = boxlogin();
	my $success = 0;

	foreach my $attempt (1, 2) {
		if ($srv->copy($msg, $target)) {
			print "Message moved to $target";
			if ($srv->delete($msg)) {
				print " and deleted from folder.";
				$success = 1;
			} else {
				print ", but could not delete it in the original folder.";
			}
			last;	# don't move another message!
		} else {
			print "Could not move message to $target.";
			if ($attempt == 1) {
				print " Trying to create folder $target... ";
				$srv->create_mailbox($target);
				$srv->select($folder);
			}
		}
	}

	if ($msg < $count) {
	    print "<do type=\"accept\" label=\"Next Msg\"><go href=\"$thisurl?msg=$msg\"/></do>";
	}
	if ($msg > 1) {
	    print "<do type=\"accept\" label=\"Previous Msg\"><go href=\"$thisurl?msg=" . ($msg - 1) . "\"/></do>";
	}
	if ($count == 1 and $success) {
		# just deleted last message in folder
		print "<do type=\"accept\" label=\"(Folder empty)\"><go href=\"$thisurl?chunk=" . sprintf("%d", ($msg - 2) / $indexchunksize) . "\"/></do>";
		print "<do type=\"accept\" label=\"Folders\"><go href=\"$thisurl?folder=0\"/></do>";
		print "<do type=\"accept\" label=\"Rm Folder\"><go href=\"$thisurl?delfolder=1\"/></do>";
	} else {
		print "<do type=\"accept\" label=\"Back to Index\"><go href=\"$thisurl?chunk=" . sprintf("%d", ($msg - 2) / $indexchunksize) . "\"/></do>";
	}

	wmlclose($srv);
}


##### Main switch ##############################################################

if ($host and $user and $pass and $folder and $delmsg) { #######################
	wmltitle("del", "Deleted $delmsg", 0);

	foldermove($delmsg, $trashfolder);

} elsif ($host and $user and $pass and $folder and $arcmsg) { ##################
	wmltitle("arc", "Archived $arcmsg", 0);

	foldermove($arcmsg, $arcfolder);

} elsif ($host and $user and $pass and $delfolder) { ###########################

	wmltitle ("rmf", "Rm Folder $folder", 0, "$thisurl?folder=0", 1);
	# refresh to Folders after 1 second

	my ($srv, $count) = boxlogin();
	if ($count) {
		print "Fresh mail in folder! Cannot remove it now.";
		print '<do type="prev"><prev/></do>';
	} elsif ($folder =~ /^inbox$/i) {
		print "Cannot remove INBOX!";
		print '<do type="prev"><prev/></do>';
	} else {
		$srv->select('INBOX');	# cannot remove current folder
		if ($srv->delete_mailbox($folder)) {
			print "Removed folder $folder.";
		} else {
			print "Could not remove folder $folder.";
		}
		print "<do type=\"accept\" label=\"Folders\"><go href=\"$thisurl?folder=0\"/></do>";
	}

	wmlclose($srv);

} elsif ($host and $user and $pass and $folder and $msg) { #####################
	my ($srv, $count) = boxlogin();
	if ($msg > $count) {
		$msg = $count;
	}

	my $out = "";
	my $quot = undef;

	my $lines = $srv->get($msg);

	for (my $index = 0; $index <= $#$lines; $index++) {
		if (${$lines}[$index] =~ /^(From|Subject|Date):\s+(.*)/i) {
			$out .= "$1: $2\n";
		}
		if (${$lines}[$index] =~ /^Content-Transfer-Encoding:.*quoted-printable/i) {
			$quot = 1;
		}
		if (${$lines}[$index] =~ /^\r?\n\r?$/) {
			splice @$lines, 0, $index;
			last;
		}
	}

	$out .= join('', @$lines);
	$out = decode_qp($out) if $quot;

	my $tchunk = $chunk;
	while ($tchunk > 0) {
		$out =~ /^(.{1,$msgchunksize})(.*)$/s;
		$out = $2;
		$tchunk--;
	}
	my $thissize = length($out);

	wmltitle("msg", "Msg $msg c $chunk~" .
		sprintf("%d", $thissize/$msgchunksize), 1);

	$out =~ /^(.{1,$msgchunksize})/s;
	$out = $1;

	# modify ASCII <hr>: compress portions of more than 15 identicals chars
	$out =~ s/(.)\1{14,}/$1 x 15/eg;

	print wmlencode($out);

	if ($thissize > $msgchunksize) {
		print "<do type=\"accept\" label=\"Next Part\"><go href=\"$thisurl?msgchunk=$msg-" . ($chunk + 1) . "\"/></do>";
	}

	if ($chunk > 0) {
		print "<do type=\"accept\" label=\"Prev Part\"><go href=\"$thisurl?msgchunk=$msg-" . ($chunk - 1) . "\"/></do>";
	}

	print "<do type=\"accept\" label=\"Back to Index\"><go href=\"$thisurl?chunk=" . sprintf("%d", ($msg - 1) / $indexchunksize) . "\"/></do>";

	if ($folder ne $trashfolder) {
		print "<do type=\"delete\" label=\"Delete\"><go href=\"$thisurl?del=$msg\"/></do>";
	}

	if ($folder ne $arcfolder) {
		print "<do type=\"accept\" label=\"Archive\"><go href=\"$thisurl?arc=$msg\"/></do>";
	}

	print '<do type="prev"><prev/></do>';

	wmlclose($srv);

} elsif ($host and $user and $pass and $folder) { ##############################
	my ($srv, $totalmsg) = boxlogin();

	my $startmsg = $chunk * $indexchunksize + 1;
	my $endmsg = ($chunk + 1) * $indexchunksize;
	if ($startmsg > $totalmsg and $totalmsg > 0) {
		$startmsg = $totalmsg;
	}
	if ($endmsg > $totalmsg) {
		$endmsg = $totalmsg;
	}

	if ($totalmsg) {
		wmltitle("idx", "$folder $startmsg-$endmsg /$totalmsg", 1);
	} else {
		wmltitle("idx", "$folder is empty", 1);
		if (not $folder =~ /^inbox$/i) {
			# offer to delete folder unless it's our inbox
			print "<do type=\"accept\" label=\"Rm Folder\"><go href=\"$thisurl?delfolder=1\"/></do>";
		}
	}

	for (my $msg = $startmsg; $msg <= $endmsg; $msg++) {
		my $from = "";
		my $subj = "";
		my $lines = $srv->top($msg, 0);
		for (my $index = 0; $index <= $#$lines; $index++) {
			if (${$lines}[$index] =~ /^From:\s+(.*)/i) {
				$from = $1;
				$from = substr($from, 0, 10);
				$from = wmlencode($from);
			}
			if (${$lines}[$index] =~ /^Subject:\s+(.*)/i) {
				$subj = $1;
				$subj = substr($subj, 0, 20);
				$subj = wmlencode($subj);
			}
			if (${$lines}[$index] =~ /^$/) {
				last;
			}
		}
		print "<a href=\"$thisurl?msg=$msg\">$msg. $from: $subj</a><br/>";
	}

	if ($endmsg < $totalmsg) {
		print "<do type=\"accept\" label=\"More Msgs\"><go href=\"$thisurl?chunk=" . ($chunk + 1) . "\"/></do>";
	}

	if ($startmsg > 1) {
		print "<do type=\"accept\" label=\"Prev Msgs\"><go href=\"$thisurl?chunk=" . ($chunk - 1) . "\"/></do>";
	}

	if (($totalmsg - $endmsg) / $indexchunksize > 1) {
		print "<do type=\"accept\" label=\"Last Chunk\"><go href=\"$thisurl?chunk=" . sprintf("%d", ($totalmsg - 1) / $indexchunksize) . "\"/></do>";
	}

	print "<do type=\"accept\" label=\"Folders\"><go href=\"$thisurl?folder=0\"/></do>";

	print '<do type="prev"><prev/></do>';
	wmlclose($srv);

} elsif ($host and $user and $pass) { ##########################################
	wmltitle("fsl", "Select Folder", 1,
		 "$thisurl?folder=" . int(rand(30000)), $refreshtime);
	# Refresh to same screen after $refreshtime.
	# We add ?folder=(random number) to $thisurl to force a refresh.
	# Reason: The E-Plus gateway does not appear to support
	# <card><onevent type="ontimer"><refresh/></onevent><timer...
	# I have not checked if <refresh/> or <onevent...> is missing.

	my $srv = new Net::IMAP::Simple($host);
	if (defined $srv->login($user, $pass)) {
		foreach my $f (sort { $a eq "INBOX" ? -1 : ($b eq "INBOX" ? 1 : $a cmp $b) } grep(!/^\./, $srv->mailboxes())) {
			next unless my $c = $srv->select($f);
			print "<a href=\"$thisurl?folder=$f\">$f ($c)</a><br/>";
		}
	} else {
		print "Could not log in to $user\@$host.";
		print "<do type=\"accept\" label=\"Try Again\"><go href=\"$thisurl?user=0\"/></do>";
	}
	print '<do type="prev"><prev/></do>';

	wmlclose($srv);

} else {				########################################
	wmltitle("log", "Login", 0);
	print	'Host: <input name="host" format="*m" value="'.$host.'"/><br/>',
		'User: <input name="user" format="*m" value="'.$user.'"/><br/>',
		'Pass: <input name="pass" type="password" format="*m" value="'.$pass.'"/><br/>',
		'<do type="accept" label="Login">',
		"<go href=\"$thisurl\" method=\"post\">",
		'<postfield name="host" value="$(host)"/>',
		'<postfield name="user" value="$(user)"/>',
		'<postfield name="pass" value="$(pass)"/>',
		'</go></do><do type="prev"><prev/></do>';
	wmlclose(undef);
}

close(LOG) if defined $logfile;