#!/usr/bin/perl -w
# pop3download.pl - downloads and deletes POP3 emails from a remote server
# Copyright (C) 2004  Peter Willis
# Version 0.5
# 
# Parts of this program were taken from
# http://iis1.cps.unizar.es/Oreilly/perl/advprog/ch12_06.htm, apparently
# a web resource for the book Advanced Perl Programming,
# written by Sriram Srinivasan.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Library General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

# CHANGELOG

# Since 0.04:
#   * Added IMAP support, for mirroring/pulling an IMAP mailbox, for example
#     to keep the size of the mailbox small
#
# Since 0.03:
#   * Fixed opening of UIDL id file; before it was using the same database
#     for all users of a pop3 server, reusing the same UIDLs for each user.


# TODO:
# * split up deliver_message into smaller functions
#   - add maildir functions as a delivery option


use strict;
use Fcntl;
use POSIX qw(setsid);
use Net::IMAP::Simple;
use Net::POP3;
use IO::Socket;
use DB_File;
use Time::HiRes;
use Sys::Hostname;
use Cwd;

$|=1;
my $VERSION = "0.04";
my $HOME = (getpwuid($>))[7];
my $programdir = ".pop3download";
if ( ! -d "$HOME/$programdir" ) {
	mkdir("$HOME/$programdir", 0700) || die "Couldn't mkdir \"$HOME/$programdir\": $!\n";
}
my $daemon = 0;

if ( defined $ARGV[0] and ($ARGV[0] eq "-h" or $ARGV[0] eq "--help") ) {
	usage();
}

emulate_fetchmail();

sub emulate_fetchmail {
	my @polls = parse_fetchmail_config();
	unless ( @polls ) {
		usage();
	}
	if ( $daemon ) {
		# daemonize
		open(STDIN,"/dev/null");
		open(STDOUT,">/dev/null");
		#open(STDERR,">/dev/null");
		#open(STDOUT,">>$HOME/$programdir/pop3download.log");
		open(STDERR,">>$HOME/$programdir/pop3download.log");
		setsid();
		fork && exit;
		for (;;) {
			sleep($daemon);
			emulate_fetchmail_polls(\@polls);
		}
	} else {
		emulate_fetchmail_polls(\@polls);
	}
	return();
}

sub emulate_fetchmail_polls {

	my $polls = shift;

	foreach my $_poll (@$polls) {

		my ($server, $proto, $user, $password, $is, $mda, $options) = split("\0", $_poll);

		# i'm a lazy b****** so i create this easy-to-check hash for options without arguments
		my %options;
		foreach my $option (split /\s+/, $options) {
			$options{$option} = 1;
		}

		my %poll = ( server => $server, proto => $proto, user => $user, pass => $password, is => $is, mda => $mda, options => \%options );
print "mda \"$mda\"\n";

		unless ( $poll{pass} ) {
			$poll{pass} = askforpass(\%poll);
		}
		die "Password not specified?\n" unless $poll{pass};

		print "Polling user \"$user\" @ server \"$server\"\n";
		my $socket = connect_to_server(\%poll);
		if ( ! $socket ) {
			print STDERR "[".localtime()."] Sorry, could not connect to $poll{server}: $!\n";
			next;
		}
		$poll{socket} = $socket;

		my %poll_state;

		my $login_state = login_to_server(\%poll);
		if ( ! $login_state ) {
			# login failed. :(
			next;
		}

		if ( (lc $poll{proto} eq "pop3" or lc $poll{proto} eq "apop") ) {
			$poll_state{INBOX}->{msgs} = $login_state;
		} elsif ( lc $poll{proto} eq "imap" ) {
			$poll_state{INBOX}->{msgs} = $poll{socket}->select("INBOX");
		}

		my ($uidl_X, $uidl_list) = load_uidl(\%poll);

		print "Number of msgs in the mailbox: " . int($poll_state{INBOX}->{msgs}) . "\n";

		my $r_msgs = $socket->list();
		while ( my ($id, $size) = each(%$r_msgs) ) {
			my $ret = 0;
			my $uidl;

			if ( lc $poll{proto} eq "pop3" or lc $poll{proto} eq "apop" ) {
				$uidl = $poll{socket}->uidl($id);
				if ( ! defined $uidl or length($uidl) < 1 ) {
					print STDERR "[".localtime()."] Error: UIDL for message \"$id\" not found; skipping.\n";
					next;
				}
			}

			# skip or download the message

			if (
				(lc $poll{proto} eq "pop3" or lc $poll{proto} eq "apop")
				&& ( (!exists $options{'fetchall'}) and (exists $$uidl_list{$uidl}) )
			) {

				# message has been seen; skip it.
				print "Skipping seen message \"$uidl\"\n";

			} elsif (
				(lc $poll{proto} eq "imap")
				&& ( (!exists $options{"fetchall"}) and ($poll{socket}->seen($id)) )
			) {

				# message has been seen; skip it
				print "Skipping seen message \"$id\"\n";

			} else {

				if ( lc $poll{proto} eq "pop3" or lc $poll{proto} eq "apop" ) {
					$$uidl_list{$uidl} = 1;
				}
				print "Downloading message $id (".$size."B)\n";
				$ret = deliver_message( \%poll, $id );

			}

			$poll{uidl_list} = $uidl_list;
			cleanup_message(\%poll, $id, $ret, $uidl);
		}

		$poll{socket}->quit();

		# should rename this 'close_uidl' really
		save_uidl($uidl_X, $uidl_list);

		print "\n\n";

	}

}

sub load_uidl {
	my $poll = shift;
        my $X = tie my %h, 'DB_File', "$HOME/$programdir/$$poll{user}\@$$poll{server}.ids", O_RDWR|O_CREAT, 0600, $DB_HASH;
	return(\$X, \%h);
}

sub save_uidl {
	my ($X, $h) = shift;
	undef($$X);
	untie(%$h);
	return(0);
}

sub cleanup_message {

	# yes, i know, this many arguments just to delete something is horrible.
	# Sue me.
	#my ($socket, $id, $ret, $optionshr, $uidl, $uidl_listhr) = @_;

	my ($poll, $id, $ret, $uidl) = @_;

	# default is 'nokeep'
	if ( (!exists $$poll{options}->{'keep'}) and ($ret == 0) ) {

		print "Marking message $id for deletion\n";
		$$poll{socket}->delete($id);

		if ( lc $$poll{proto} eq "pop3" or lc $$poll{proto} eq "apop" ) {
			delete $$poll{uidl_list}->{$uidl};
		}

	} elsif ( $ret != 0 ) {

		print STDERR "[".localtime()."] Delivery of message $id seems to have failed; not deleting from server.\n";
		return(1);

	}

	return(0);

}

sub parse_fetchmail_config {

	my @polls = ();
	my $polls = 0;
	return() unless (-e "$HOME/.fetchmailrc");

	if ( ! open(CONFIG, "$HOME/.fetchmailrc") ) {
		print STDERR "[".localtime()."] Could not open \"$HOME/.fetchmailrc\": $!\n";
		return();
	}

	my $ret = read(CONFIG, my $buffer, -s "$HOME/.fetchmailrc");

	return() unless $ret;

	close(CONFIG);

	$buffer =~ s/^\s*#.*$//mg; # remove comments
	$buffer =~ s/(\r|\n)/ /g; # remove newlines
	$buffer =~ s/\s+/ /g; # make multiple spaces into a single space
	$buffer =~ s/poll/\n\npoll/g; # make each word "poll" be on its own new line

	foreach my $line (split(/\n/,$buffer)) {

		my ($server, $proto, $user, $password, $is, $mda, $options);
		if ( $line =~ /^poll ([a-zA-Z0-9.-]+)/ ) {

			$server = $1;
			$server .= ( $line =~ /port (\d+)/ ? ":$1" : "" );
			$proto = $2 if ( $line =~ /proto(col)? (\S+)/ );
			$user = $2 if ( $line =~ /user(name)? (\S+)/ );
			$password = $1 if ( $line =~ /password (\S+)/ );
			$is = $1 if ( $line =~ /is (\S+)/ );

			if ( $line =~ /mda ('|")/ ) {

				my $quot = $1;
				$mda = $1 if ( $line =~ /mda $quot(.+)$quot/ );

			} else {

				$mda = $1 if ( $line =~ /mda (\S+)/ );

			}

			$options .= " fetchall" if ( $line =~ /\Wfetchall\W/ );
			$options .= " keep" if ( $line =~ /\Wkeep\W/ );
			$options .= " forcecr" if ( $line =~ /\Wforcecr\W/ );
			#print "line $line\n\t$server, $proto, $user, $password\n";

			$polls[$polls++] = join("\0", $server, $proto, $user, $password, $is ? $is : "", $mda ? $mda : "", $options ? $options : "");

		} else {

			if ( $line =~ /set daemon (\d+)/ ) {
				$daemon = $1;
			}

		}

	}

	return(@polls);

}

sub deliver_message {

	my ($poll, $id) = @_;

	# we create a temp file and transfer the email to it, then open it back
	# up and scan for %F (the From: field) to be used in the mda if needed.
	# 
	# also, this could be useful in a home-grown implementation of Maildir
	# support; in cases where the user didn't have an MDA or MTA and just
	# wanted to store their email into a Maildir for browsing with their
	# IMAP client and their IMAP server, we could simply link this temp
	# file into the Maildir and delete the temp file. mbox support might
	# also be possible; i'll have to look up any relevant RFC's and whatnot,
	# but i believe new messages are simply written to the end of the mail
	# spool file.

	# create temp file variable
	my $tmpfile = "/";
	while ( -e $tmpfile ) {
		my ($time, $utime) = Time::HiRes::gettimeofday();
		$tmpfile = "$HOME/$programdir/$$-$time.$utime";
		if ( -e $tmpfile ) {
			sleep 1;
		} else {
			last;
		}
	}

	my $messagefd;
	# open temp file for writing
	if ( ! open($messagefd,">$tmpfile") ) {
		print STDERR "[".localtime()."] Error opening tmpfile \"$tmpfile\" read-write: $!\n";
		return(1);
	}

	# "get" the message, sending it to $messagefd
	my $msgfh = $$poll{socket}->getfh($id);
	while ( read($msgfh, my $buffer, 4096) ) {
		print $messagefd $buffer;
	}
	# do not close $msgfh; we will get an EOF, then just don't use that fh again (apparently)
	close($messagefd);

	# open it back up
	if ( ! open($messagefd, "<$tmpfile") ) {
		print STDERR "[".localtime()."] Error opening temp file \"$tmpfile\" read-only: $!\n";
		return(1);
	}

	my $writingfd;
	if ( defined $$poll{mda} and length $$poll{mda} > 0 ) {

		# if $mda contains %F ...
		if ( $$poll{mda} =~ /\%F/ ) {

			my $from;
			# parse out the From line for passing to the mda
			while ( <$messagefd> ) {

				chomp;
				if ( $_ eq "" ) {

					# if the line is empty, means we finished parsing the headers.
					last;

				} elsif ( $_ =~ /^From: .+$/ ) {

					# find the From: line and replace %F in $mda with it.
					# NOTE: THIS DOES NOT PARSE OUT THE EMAIL ADDRESS CORRECTLY!
					# BUYER BEWARE!
					if ( $_ =~ /<?\[?([\@a-zA-Z0-9\-_.\t ]+)\]?>?\s*$/ ) {
						$$poll{mda} =~ s/\%F/\"$1\"/g;
					}

				}

			}

		}

		# replace %T with "is USERNAME here" value
		$$poll{mda} =~ s/\%T/\"$$poll{is}\"/g if ( defined $$poll{is} );
		# open the $mda pipe

		if ( ! open($writingfd, "| $$poll{mda}") ) {
			print STDERR "[".localtime()."] Couldn't open pipe to mda \"$$poll{mda}\": $!\n";
			return(1);
		}

	} else {

		$writingfd = IO::Socket::INET->new(PeerAddr => "127.0.0.1", PeerPort => 25, Proto => "tcp");
		if ( ! $writingfd ) {
			print STDERR "[".localtime()."] Couldn't open socket to 127.0.0.1:25: $!\n";
			return(1);
		}

	}

	seek($messagefd, 0, 0);

	# write the message
	#while ( <$messagefd> ) {
	#	print $writingfd $_;
	#}

	while ( sysread($messagefd, my $buffer, 4096,) ) {
		# forcecr option; turns bare CR or LF into CRLF.
		# hard-coded values to conform to internet standards
		# and move away from operating system porting issues.
		if ( exists $$poll{options}->{forcecr} ) {
			$buffer =~ s/\013[^\010]/\013\010/g;
			$buffer =~ s/[^\013]\010/\013\010/g;
		}
		syswrite($writingfd, $buffer);
	}

	close($messagefd);

	# remove the temp file.
	if ( -e $tmpfile ) {
		if ( ! unlink($tmpfile) ) {
			print STDERR "[".localtime()."] Error unlinking \"$tmpfile\": $!\n";
			close($writingfd);
			return(1);
		}
	}

	close($writingfd);

	# wrap it up
	if ( defined $$poll{mda} ) {
		if ( $! == 0 ) {
			return($?);
		}
	}

	return(0);

}

## sample filename:
## 1096702001.M816693P3286V0000000000000306I0009DB28_0.meatwad
sub open_maildir_file {
	my $maildir = shift;
	my @time;
	my @stat;
	my $filename;
	my $hostname;
	my $fh;
	my $inctime = 0;
	my $cwd = getcwd();
	CREATEMAILDIRFILE:
	chdir($cwd); # put us back to the original dir
	if ( ! chdir($maildir) ) {
		print STDERR "[".localtime()."] Error: could not chdir($maildir): $!; mail not delivered.\n";
		return();
	}
	@time = Time::HiRes::gettimeofday();
	@stat = stat(".");
	if ( ! @stat ) {
		print STDERR "[".localtime()."] Error: stat . didn't work??\n";
		return();
	}
	# The Makings Of A Unique File Name, Sort Of.
	# filename = time(), mtime(), process,
	$filename = "$time[0].M$time[1]P$$";
	# device name in hex with up to 17 leading zero's,
	$filename .= "V" . sprintf("%017lx", $stat[0]);
	$filename .= "I" . sprintf("%08lx", $stat[1]);
	$hostname = hostname();
	if ( !defined $hostname or length($hostname) < 1 ) {
		# no hostname for some weird reason, so use random data instead.
		# hostname will be random data in hex-digits.
		my $rndhostlen = 10; # arbitrary
		if ( -e "/dev/urandom" ) {
			my $buffer;
			if ( ! open(RND, "/dev/urandom") ) {
				goto CRAPRNDREAD;
			}
			if ( ! read(RND, $buffer, $rndhostlen) ) {
				goto CRAPRNDREAD;
			}
			$hostname = map { sprintf "%02lx", ord($_) } split //, $buffer;
			close(RND);
		} else {
			# last ditch effort incase this isn't a Linux box
			CRAPRNDREAD:
			srand();
			for (my $i=0;$i<$rndhostlen;$i++) {
				$hostname .= sprintf "%02lx", (int(rand(26))+97);
			}
		}
	}

	$filename .= ".$hostname";

	# filename is ready; now try and open it.
	if ( -e "tmp/$filename" ) {
		if ( $inctime > ((60*60)*24) ) {
			print STDERR "[".localtime()."] Error: i've been trying to create this temp file for 24 hours! ENOUGH IS ENOUGH!\n";
			return();
		}
		sleep 2;
		$inctime += 2;
		goto CREATEMAILDIRFILE;
	}

	if ( ! open($fh, ">tmp/$filename") ) {
		print STDERR "[".localtime()."] Error: could not create temp file \"tmp/$filename\": $!\n";
		return();
	}

	return($fh, $filename);
}

sub close_maildir_file {

	my $maildir = shift;
	my $maildirfh = shift;
	my $mailfile = shift;

	if ( ! close($maildirfh) ) {
		print STDERR "[".localtime()."] Error: closing an already closed fh for mail file \"$mailfile\"\n";
		return 1;
	}

	if ( ! chdir($maildir) ) {
		print STDERR "[".localtime()."] Error: chdir($maildir) failed: $!; mail stuck in tmp?\n";
		return 1;
	}

	if ( ! -d "new" or ! -d "tmp" ) {
		print STDERR "[".localtime()."] Error: \"new\" or \"tmp\" directory not found; is \"$maildir\" a valid maildir?\n";
		return 1;
	}

	if ( ! -e "tmp/$mailfile" ) {
		print STDERR "[".localtime()."] Error: trying to close inexistant mail file \"tmp/$mailfile\"\n";
		return 1;
	}

	if ( ! rename("tmp/$mailfile", "new/$mailfile") ) {
		print STDERR "[".localtime()."] Error: renaming \"tmp/$mailfile\" to \"new/$mailfile\" failed: $!\n";
		return 1;
	}

	return 0;

}

sub connect_to_server {

	my $poll = shift;
	my $m;

	if ( lc $$poll{proto} eq "pop3" or lc $$poll{proto} eq "apop" ) {

		$m = Net::POP3->new($$poll{server}); # Name of POP server

	} elsif ( lc $$poll{proto} eq "imap" ) {

		$m = Net::IMAP::Simple->new($$poll{server});

	}

	return($m);

}

sub login_to_server {

	my $poll = shift;
	my $n;

	if ( lc $$poll{proto} eq "pop3" or lc $$poll{proto} eq "imap" ) {

		$n = $$poll{socket}->login($$poll{user}, $$poll{pass});

	} elsif ( lc $$poll{proto} eq "apop" ) {

		$n = $$poll{socket}->apop($$poll{user}, $$poll{pass});

	}

	if ( ! $n ) {
		print STDERR "[".localtime()."] Login for \"$$poll{user}\@$$poll{server}\" not correct\n";
	}

	return($n);

}

sub askforpass {

	my $poll = shift;

	print $$poll{user}.'@'.$$poll{server}."'s password please: ";
	system("stty -echo");
	my $pass = <STDIN>;
	system("stty echo");
	print "\n";
	chomp $pass;

	return($pass);

}

sub usage {

	$0 =~ s/^.+[\/]([^\/]+)$/$1/g;
	print <<EOF;
$0 Version $VERSION
Usage: $0
  $0 parses \$HOME/.fetchmailrc and fetches mail from each section
  starting with "poll".
  
  Check the fetchmail(1) man page for details on configuration.
EOF
	exit(1);

}