#!/usr/bin/perl -Tsw
#
# $Cambridge: hermes/src/2hermes/2hermes,v 1.35 2007/09/19 13:51:52 fanf2 Exp $

use strict;

# taint control must go before the libraries are initialized
# because File::Find does stuff with `pwd` when it is loaded.
BEGIN {
	$ENV{PATH} = '';
}

use File::Find;
use IO::Handle;
use Socket;

# for simple switch parsing

use vars qw{ $d $v };

my $poponly = ($0 =~ /pop2hermes/);

# General settings

my $BINDIR = '/opt/2hermes/bin'; # see Makefile
my $ETCDIR = '/opt/2hermes/etc';
my $IMAPUPLOAD = "$BINDIR/imapupload";
my $STUNNEL = "$BINDIR/stunnel -f -Derr -c -v3 -A $ETCDIR/cert.pem -r hermes.cam.ac.uk:56789";
my $STTY = '/bin/stty';
my $FROMSYSTEM = 'cus.cam.ac.uk';

########################################################################

sub check ($$) {
	my $msg = shift;
	my $val = shift;
	if (defined $val) {
		return $val;
	} else {
		die "$msg: $!\n";
	}
}

sub debug (@) {
	return unless $d;
	print STDERR map /\n$/ ? "$_" : "$_\n", @_;
}

sub say (@) {
	print map /\n$/ ? "$_" : "$_\n", @_;
}

sub prompt_yn ($) {
	$_[0] = "Confirm?" unless @_;
	for (;;) {
		print "> @_ (y/n) ";
		my $yn = <>;
		exit 1 if not defined $yn;
		return 1 if $yn =~ /^\s*y/i;
		return 0 if $yn =~ /^\s*n/i;
	}
}

########################################################################
#
#  forward file fixing
#

sub fixfwd_there ($$) {
	my $user = shift;
	my $pass = shift;
	my $printing = 0;
	my $oldnew;
	my $ok = 1;

	check "stunnel: socketpair: $!",
	    socketpair FIXFWD, STUNNEL, AF_UNIX, SOCK_STREAM, PF_UNSPEC;

	my $pid = check "stunnel: fork", fork;
	if ($pid == 0) {
		# child
		close FIXFWD;
		check "stunnel: open error stream",  open STDERR, ">&STUNNEL";
		check "stunnel: open output stream", open STDOUT, ">&STUNNEL";
		check "stunnel: open input stream",  open STDIN, "<&STUNNEL";
		exec $STUNNEL;
		die "stunnel: exec $STUNNEL: $!\n",
	}
	# parent
	close STUNNEL;
	FIXFWD->autoflush;
	while (<FIXFWD>) {
		if (/^\|/) {
			# OK
			if (/Your account is on/) {
				/(old|new)/;
				$oldnew = $1;
			}
			print if $printing;
			next;
		}
		if (/^\>/) {
			# prompt
			if (/Username/) {
				print FIXFWD "$user\n";
				next;
			}
			if (/Password/) {
				print FIXFWD "$pass\n";
				next;
			}
			if (/Migrating from/) {
				print FIXFWD "$FROMSYSTEM\n";
				$printing = 1;
				next;
			}
			print;
			my $ans = <STDIN>;
			$ans =~ s/^\s*//;
			$ans =~ s/\s*$//;
			print FIXFWD "$ans\n";
			next;
		}
		# line started with an unknown char, so there's a problem
		print;
		$ok = 0;
		next;
	}
	wait;
	if ($ok) {
		return $oldnew;
	} else {
		return undef;
	}
}

sub fixfwd_here ($$) {
	my $user = shift;
	my $home = shift;

	my $forwardaddr = "$user\@hermes.cam.ac.uk\n";
	my $forwardfile = "$home/.forward";
	my $forwardback;
	my $forwardundo;
	for (my $i = 0;; $i++) {
		$forwardback = "$forwardfile.$i";
		last unless -e $forwardback;
	}

	if (-f $forwardfile
	    and defined open FWD, $forwardfile
	    and <FWD> ne $forwardaddr) {
		say <<HERE_ENDETH;
You have a local .forward file. This will be renamed to $forwardback
You can use https://webmail.hermes.cam.ac.uk/ to set up equivalent filtering
on Hermes (click on Manage then one of the Mail Processing buttons).
HERE_ENDETH
		rename $forwardfile, $forwardback
		    or say "Warning: rename $forwardfile, $forwardback: $!";
		$forwardundo = "mv $forwardback $forwardfile";
	} else {
		$forwardundo = "rm $forwardfile";
	}
	say <<HERE_ENDETH;
Creating a new local .forward file to redirect $FROMSYSTEM email to Hermes.
HERE_ENDETH
	check "Error: open $forwardfile", open FORWARD, "> $forwardfile";
	print FORWARD $forwardaddr;
	check "Error: writing $forwardfile", close FORWARD;
	say <<HERE_ENDETH;
Local redirection updates completed OK.
To undo the email routing changes, run these commands on $FROMSYSTEM:
\$ $forwardundo
\$ cammail sendhere
HERE_ENDETH
	return 1;
}

sub fixfwd ($$$) {
	my $user = shift;
	my $pass = shift;
	my $home = shift;

	my $oldnew = fixfwd_there $user, $pass;
	if (defined $oldnew) {
		if (not defined eval { fixfwd_here $user, $home }) {
			print $@;
			undef $oldnew;
		}
	}
	return $oldnew if defined $oldnew;
	say <<HERE_ENDETH;
There was a problem sorting out your email forwarding settings.
Please fix the problem that caused the error described above
or contact <help-desk\@ucs.cam.ac.uk> for assistance.
HERE_ENDETH
	exit;
}

########################################################################
#
#  find mailbox files and upload them
#

# list of folders to upload
my @iu_folders;

# this hash is keyed by the $dev.$ino pair for weeding out aliases
my %iu_devino;

# we also want to know how much space they are using in case we risk
# blowing their quota on hermes
my $iu_space = 0;

my %iu_quota = ( old => 10*1024*1024, new => 250*1024*1024 );

sub notfound (;$) {
	return unless $v;
	my $msg = shift || $!;
	say "skipping $File::Find::name: $msg";
}

sub found {
	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size) = stat
	    or return notfound;

	return notfound "not a file" unless -f _;
	return notfound "empty file" if -z _;

	if (exists $iu_devino{"$dev.$ino"}) {
		my $dup = $iu_devino{"$dev.$ino"};
		return notfound "duplicate of $dup";
	}
	$iu_devino{"$dev.$ino"} = $File::Find::name;

	# does it look plausibly like a mail folder?
	open FOLDER, "< $_"
	    or return notfound;
	my $firstline = <FOLDER>;
	close FOLDER;
	$firstline =~ /^From /
	    or return notfound "not a mail folder";

	push @iu_folders, $File::Find::name;
	$iu_space += $size;
}

sub imapupload ($$$$) {
	my $user = shift;
	my $pass = shift;
	my $home = shift;
	my $oldnew = shift;

	say "Preparing to upload your saved email...";

	check "Could not change to home directory $home",
	    chdir $home;
	my @findroots =
	    ("/var/spool/mail/$user",
	     "/var/mail/$user",
	     "inbox",
	     "mbox",
	     "Mail",
	     "mail");
	find { wanted => \&found,  untaint => 1 }, grep -e $_, @findroots;

	my $M = 1024*1024;
	my $mb_space = int (($iu_space + $M - 1) / $M);
	say "Space used for saved email = $mb_space MB";
	if ($iu_space > 0.8 * $iu_quota{$oldnew}) {
		say <<HERE_ENDETH;
The following email folders add up to more than 80% of the default
Hermes quota. The upload operation will fail if there isn't enough
space in your account. You can ask for a quota increase using an
online form at http://www.cam.ac.uk/cs/request/quota.html
If you abort now, you can re-run this program to upload your saved
email to Hermes later (e.g. after you have a larger quota or you have
moved some email to another place so it isn't uploaded). New email
will be delivered to Hermes whether or not you upload your old email.
HERE_ENDETH
		print map "\t$_\n", @iu_folders;
		exit unless prompt_yn
		    "Continue and try to upload the above folders?";
	}

	say <<HERE_ENDETH;
This program can ensure that email folder names do not clash, by
renaming any folders on this system that have the same name as folders
that already exist on Hermes. Alternatively it can leave the names the
same, and if there is a clash the uploaded messages will be added to
the end of the existing folder on Hermes.
HERE_ENDETH
	my $opts;
	if (prompt_yn "Avoid name clashes?") {
		$opts = "-fpr";
	} else {
		$opts = "-fp";
	}
	$opts .= 'd' if $d;
	# old Hermes pathname compatibility
	$opts .= 'm' if $oldnew eq 'old';
	check "imapupload: socketpair: $!",
	    socketpair IMAPUPLOAD, CHILD, AF_UNIX, SOCK_STREAM, PF_UNSPEC;
	my $pid = check "imapupload: fork", fork;
	if ($pid == 0) {
		# child
		close IMAPUPLOAD;
		check "imapupload: open error stream",  open STDERR, ">&CHILD";
		check "imapupload: open output stream", open STDOUT, ">&CHILD";
		check "imapupload: open input stream",  open STDIN, "<&CHILD";
		exec $IMAPUPLOAD, $opts, 'imap.hermes.cam.ac.uk';
		die "imapupload: exec $IMAPUPLOAD: $!\n",
	}
	# parent
	close CHILD;
	IMAPUPLOAD->autoflush;
	print IMAPUPLOAD map "$_\n", $pass, @iu_folders;
	check "imapupload: shutdown", shutdown IMAPUPLOAD, 1; # SHUT_WR
	while (<IMAPUPLOAD>) { print };
	check "imapupload: close", close IMAPUPLOAD;
	wait;
	if ($? == 2 << 8) {
		say <<HERE_ENDETH;
You can upload your saved email to Hermes later
by running this program again.
HERE_ENDETH
		return;
	}
	die "imapupload failed\n" if $? != 0;
	say "Folder upload completed.";
}

########################################################################
#
#  main program
#

if ($poponly) {
	say <<HERE_ENDETH;
This program will help you migrate your email to Hermes.
Your forwarding settings for \@cam.ac.uk, \@hermes.cam.ac.uk,
and \@$FROMSYSTEM email will be updated so that your
email is delivered to Hermes. This is intended for use by
POP3 users. If you have saved email on $FROMSYSTEM
you should use the 2hermes program instead.
Press CTRL+C now if you do not want your email forwarding changed!
HERE_ENDETH
} else {
	say <<HERE_ENDETH;
This program will help you migrate your email to Hermes.
There are two parts to the process: Firstly, your forwarding
settings for \@cam, \@hermes, and \@$FROMSYSTEM email are
updated so that your email is delivered to Hermes. Secondly,
your saved email is uploaded to Hermes so that you can still
access it conveniently.
Press CTRL+C now if you do not want your email forwarding changed!
HERE_ENDETH
}

my @pw = getpwuid $<
    or die "You don't exist. Go away.\n";
$pw[0] =~ /^([a-z]+[0-9]*)$/
    or die "Bad username\n";
my $user = $1;
$pw[7] =~ /(.*)/;
my $home = $1;

system $STTY, '-echo' and die "stty -echo failed\n";
print "Please enter your Hermes password: ";
my $pass = <STDIN>;
system $STTY, 'echo' and die "stty echo failed\n";
exit 1 unless defined $pass;
chomp $pass;
print "\n";

my $oldnew = fixfwd $user, $pass, $home;

imapupload $user, $pass, $home, $oldnew
    unless $poponly;

say <<HERE_ENDETH;
Enjoy using Hermes!
Remember to change your email software settings to use
imap.hermes.cam.ac.uk, pop.hermes.cam.ac.uk, and smtp.hermes.cam.ac.uk
as appropriate.
HERE_ENDETH

exit;