#!/usr/bin/perl -Tsw
#
# $Cambridge: hermes/src/2hermes/fixfwd,v 1.41 2005/05/16 13:55:47 fanf2 Exp $

use strict;

use IO::Handle;
use GDBM_File;
use POSIX;
use Socket;
use Sys::Syslog;

# for simple switch parsing and MSshell

use vars qw{ $d $MSversion $forwardfile $mailregexp };

# taint control

$ENV{PATH} = '';
$0 =~ /(.*)/;
my $PROG = $1;

# general settings

my $CDBGET = '/opt/cdb/bin/cdbget';
my $CYRUSMAP = '/opt/dist/users/cyrus.cdb';
my $LOGID = 'fixfwd';
my $LOGFAC = 'LOCAL2'; # see /etc/syslog.conf on prism
my $PIDFILE = '/var/run/fixfwd.pid'; # see rc.fixfwd
my $PORT = 56788; # see stunnel.conf
my $SIEVEPORT = 2000;
my $YPDB = '/var/yp/YPhermes.cam.ac.uk/shadow.byname';

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

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

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

sub chawmp ($) {
	my $val = shift;
	$val =~ s/^\s*//;
	$val =~ s/\s*$//;
	$val =~ /(.*)/;
	return $1;
}

sub say (@) {
	print CLIENT map {
		my $line = $_;
		$line =~ s/^/\| /gm;
		$line =~ s/\n?$/\n/;
		$line;
	} @_;
}

sub err ($$) {
	my $level = shift;
	my $msg = shift;
	syslog $level, $msg;
	print CLIENT "Error: $msg\n";
}

sub prompt ($) {
	print CLIENT "> @_\n";
	return chawmp <CLIENT>;
}

sub prompt_yn () {
	for (;;) {
		print CLIENT "> Confirm? (y/n)\n";
		my $yn = chawmp <CLIENT>;
		return 1 if $yn =~ /^y/i;
		return 0 if $yn =~ /^n/i;
	}
}

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

# For SASL authentication

my $b64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";

sub base64 ($) {
	my $string = shift;
	my $ret = "";

	while($string =~ m/(.)(.)?(.)?/g) {
		if(defined $3) {
			my ($o1,$o2,$o3) = (ord $1, ord $2, ord $3);
			$ret .= substr $b64, $o1 >> 2, 1;
			$ret .= substr $b64, ($o1 << 4 | $o2 >> 4) & 63, 1;
			$ret .= substr $b64, ($o2 << 2 | $o3 >> 6) & 63, 1;
			$ret .= substr $b64, $o3 & 63, 1;
		} elsif(defined $2) {
			my ($o1,$o2) = (ord $1, ord $2);
			$ret .= substr $b64, $o1 >> 2, 1;
			$ret .= substr $b64, ($o1 << 4 | $o2 >> 4) & 63, 1;
			$ret .= substr $b64, ($o2 << 2) & 63, 1;
			$ret .= '=';
		} else {
			my $o1 = ord $1;
			$ret .= substr $b64, $o1 >> 2, 1;
			$ret .= substr $b64, ($o1 << 4) & 63, 1;
			$ret .= '==';
		}
	}
	return $ret;
}

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

# perl doesn't support getspnam, so we rely on excessively intimate
# knowledge of the authentication infrastructure on hermes.

sub auth ($$) {
	my $user = shift;
	my $pass = shift;

	my %spwdb;
	tie %spwdb, 'GDBM_File', $YPDB, 0, 0
	    or return "$!";
	return "bad login" unless defined $spwdb{$user};
	debug "$user $pass $spwdb{$user}";
	$spwdb{$user} =~ /^$user:([^:]+):+$/
	    or return "bad login";
	my $crypt = $1;
	debug "$pass $crypt", crypt $pass, $crypt;
	$crypt eq crypt $pass, $crypt
	    or return "bad login";
	return undef;
}

sub cdbget ($$) {
	my $file = shift;
	my $key = shift;

	my $pid = check "cdbget: pipe/fork",
	    open PIPE, "-|";
	if ($pid == 0) {
		# child
		check "cdbget: open $file",
		    open STDIN, $file;
		check "cdbget: exec $CDBGET $key",
		    exec $CDBGET, $key;
	} else {
		# parent
		my $result = join '', <PIPE>;
		return $result if close PIPE;
		# no data
		return undef if $? == 256;
		err 'err', "cdbget command failed: $! $? $result";
		exit 1;
	}
}

sub cammail ($) {
	my $cmd = shift;
	my $cammail = chawmp `/opt/OpenSSH/bin/ssh -x -n -l cammail jackdaw.cam.ac.uk $cmd 2>&1`;
	debug $cammail;
	if ($? == 0) {
		return $cammail;
	} else {
		err 'err', "cammail $cmd failed: $cammail";
		return undef;
	}
}

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

# Sieve file checksum for verifying that
# the file is automatically maintained

my $cksumline = "# END SIEVE FILE. CHECKSUM=";

sub checksum_calc (@) {
	my @file = @_;
	my $calcsum = 0;
	for my $line (@file) {
		next if $line =~ /^#/;
		$line =~ s/\s+$//;
		my $linesum = 0;
		for my $i (1 .. length $line) {
		    $linesum += $i * ord substr $line, $i - 1, 1;
		}
		$calcsum += $linesum % 65536;
	}
	return $calcsum;
}

sub checksum_saved (@) {
	my @file = @_;
	my $savedsum;
	for my $line (@file) {
		$savedsum = $1 if $line =~ /^$cksumline(\d+)\r\n$/o;
	}
	return $savedsum;
}

sub checksum_ok (@) {
	my @file = @_;
	my $savedsum = checksum_saved @file;
	my $calcsum = checksum_calc @file;
	return defined $savedsum && $calcsum == $savedsum;
}

sub checksum_add (@) {
	my @file = @_;
	my $calcsum = checksum_calc @file;
	push @file, "$cksumline$calcsum\r\n";
	return @file;
}

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

# Sieve protocol utilities with shoddy parsing

sub sieve_resp (;\@) {
	my $resp = shift;

	for(;;) {
		my $line = <SIEVE>;
		debug "< $line";
	        if ($line =~ /^(OK|NO|BYE)\s+({(\d+)\+?}\s+$)?/) {
			return $line unless defined $2;
			my $length = $3 + length $line;
			while (length $line < $length) {
				my $extra = <SIEVE>;
				debug "< $extra";
				$line .= $extra;
			}
			return $line;
		}
		push @{$resp}, $line if ref $resp;
	}
}

sub sieve_cmd ($;\@) {
	my $cmd = shift;
	my $resp = shift;

	print SIEVE "$cmd\r\n";
	debug "> $cmd";
	return sieve_resp @{$resp};
}

sub sieve_put ($@) {
	my $script = shift;
	my @script = @_;
	my $length = 0;
	map { $length += length } @script;
	print SIEVE "PUTSCRIPT \"$script\" {$length+}\r\n", @script, "\r\n";
	debug map "> $_", "PUTSCRIPT \"$script\" {$length+}", @script;
	return sieve_resp;
}

sub sieve_ok ($) {
	my $resp = shift;
	return $resp =~ /^OK\s/;
}

sub sieve_check ($$) {
	my $cmd = shift;
	my $resp = shift;
	die "$cmd failed: $resp\n" unless sieve_ok $resp;
}

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

sub fixfwd_old ($$$) {
	my $user = shift;
	my $home = shift;
	my $from = shift;

	# for MSshell's initialization
	$ENV{LOGNAME} = $user;
	$ENV{USER} = $user;
	$ENV{HOME} = $home;
	$MSversion = 'current';

	# we get some help from these bits from MSshell
	# temporarily turn off warnings while loading it.
	local $^W;
	undef $^W;
	require "/opt/MSshell/current/MSshell.pl";
	require "/opt/MSshell/current/MSshell-filter.pl";
	$^W = 1;

	if (! -f $forwardfile) {
		say "You have not set up filtering on Hermes,",
		    "so nothing needs to be done about it.";
		syslog 'info', "no $forwardfile";
		return 1;
	}
	my @actions = &read_MSactions();
	if (@actions == 0 or &test_file_checksum($forwardfile)) {
		say "You have a manually maintained .forward file.";
		my $moveit = 0;
		if (defined open FWD, $forwardfile) {
			my $fwd = join '', <FWD>;
			close FWD;
			# old-style or exim-style redirection?
			if ($fwd =~ /^\s*$mailregexp\s*$/ or
			    ($fwd =~ /^\s*#\s+exim\s+filter\b/i and
			     $fwd =~ /\bdeliver\b/)) {
				say <<HERE_ENDETH;
It looks like it might redirect email away from Hermes.
Your email will bounce if it subsequently ends up at $user\@$from.
Should your .forward be disabled so that your email is delivered on Hermes?
HERE_ENDETH
				syslog 'info', "confirming rename of" .
				    " manual $forwardfile";
				$moveit = prompt_yn;
			} else {
				say <<HERE_ENDETH;
It looks like it will deliver all email on Hermes.
HERE_ENDETH
				    $moveit = 0;
			}
		} else {
			say <<HERE_ENDETH;
Your .forward file is not readable. I'll try to disable it...
HERE_ENDETH
			$moveit = 1;
		}
		if ($moveit) {
			if (rename "$forwardfile", "$forwardfile.bak") {
				say "Renamed $forwardfile to $forwardfile.bak";
				syslog 'info', "manual $forwardfile" .
				    " renamed to $forwardfile.bak";
			} else {
				say "Warning: couldn't rename $forwardfile" .
				    " to $forwardfile.bak: $!";
				syslog 'err', "rename manual $forwardfile" .
				    " to $forwardfile.bak: $!";
			}
		} else {
			say "Leaving it in place.";
			syslog 'info', "manual $forwardfile left in place";
		}
		return 1;
	}
	say "You have set up filtering using webmail or the menu system.";
	for my $action (@actions) {
		next unless $action->{action} eq "redirect";
		say "Your email is redirected to $action->{address}.";
		if ($action->{address} ne "$user\@$from") {
			say <<HERE_ENDETH;
Your email will bounce if it subsequently ends up at $user\@$from.
Should the redirection be removed so that your email is delivered on Hermes?
HERE_ENDETH
			syslog 'info', "confirming alteration of" .
			    " auto $forwardfile";
		}
		if ($action->{address} eq "$user\@$from"
		    or prompt_yn) {
			say "Removing the redirection...";
			@actions = remove_redirect(@actions);
			write_MSactions(@actions);
			write_forward(@actions);
			say "Done.";
			syslog 'info', "removed auto $forwardfile " .
			    " redirection to $action->{address}";
			return 1;
		} else {
			say "Leaving it in place.";
			syslog 'info', "auto $forwardfile" .
			    " redirection to $action->{address} left in place";
			return 1;
		}
	}
	say "You have not set up a redirection action,",
	    "so nothing needs to be done about it.";
	syslog 'info', "auto $forwardfile has no redirection";
	return 1;
}

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

sub fixfwd_new ($$$$) {
	my $user = shift;
	my $pass = shift;
	my $machine = shift;
	my $from = shift;

	my ($name,$aliases,$addrtype,$length,@addr) =
	    gethostbyname $machine, AF_INET;
	die "Hostname lookup failed: $machine\n"
	    unless @addr and $addr[0] =~ /^(....)$/;
	my $addr = $1;

	check "socket", socket SIEVE, PF_INET, SOCK_STREAM, 0;
	check "connect", connect SIEVE, sockaddr_in $SIEVEPORT, $addr;
	SIEVE->autoflush;

	my @cap;
	my $resp = sieve_resp @cap;
	sieve_check "ManageSieve server", $resp;
	die "ManageSieve server does not support SASL PLAIN authentication\n"
	    unless grep /^"SASL" .*[" ]PLAIN[ "]/, @cap;
	sieve_check "AUTHENTICATE PLAIN",
	    sieve_cmd 'AUTHENTICATE "PLAIN" "' . base64("\0$user\0$pass") . '"';
	my @scripts;
	sieve_check "LISTSCRIPTS", sieve_cmd "LISTSCRIPTS", @scripts;
	my $active;
	unless (grep {/^"([^\"]*)" ACTIVE\r\n$/ and $active = $1} @scripts) {
		say "You have not set up filtering on Hermes,",
		    "so nothing needs to be done about it.";
		syslog 'info', "$user has no active script";
		sieve_cmd "LOGOUT";
		return 1;
	}
	my @auto;
	my $auto = sieve_cmd 'GETSCRIPT "auto"', @auto;
	shift @auto; pop @auto; # remove framing
	my @sieve;
	my $sieve = sieve_cmd 'GETSCRIPT "sieve"', @sieve;
	shift @sieve; pop @sieve; # remove framing
	AUTO: if ($active eq "sieve"
		  and sieve_ok $auto
		  and sieve_ok $sieve
		  and checksum_ok @sieve) {
		say "You have set up filtering using webmail or the menu system.";
		for(my $i = 0; $i < @auto; ++$i) {
			next unless $auto[$i] =~ /^#redirect\r\n$/;
			unless ($auto[$i+1] =~ /^#\s+address\s+(\S+)\r\n$/) {
				say "Webmail filtering file corrupt; ".
				    "falling back to manual mode.";
				syslog 'err', "${user}'s auto script corrupt";
				last AUTO;
			}
			my $address = $1;
			say "Your email is redirected to $address.";
			if ($address ne "$user\@$from") {
				say <<HERE_ENDETH;
Your email will bounce if it subsequently ends up at $user\@$from.
Should the redirection be removed so that your email is delivered on Hermes?
HERE_ENDETH
				syslog 'info', "confirming alteration of" .
				    " ${user}'s auto script";
			}
			if ($address eq "$user\@$from"
			    or prompt_yn) {
				say "Removing the redirection...";
				if ($auto[$i+2] =~ /^#\s+copy\s+(\S+)\r\n$/) {
					splice @auto, $i, 3;
					splice @sieve, -3;
				} else {
					splice @auto, $i, 2;
					splice @sieve, -2;
				}
				$auto = sieve_put "auto", @auto;
				$sieve = sieve_put "sieve", checksum_add @sieve;
				if (sieve_ok $auto and sieve_ok $sieve) {
					syslog 'info', "removed ${user}'s auto script " .
					    " redirection to $address";
					say "Done.";
				} else {
					say <<HERE_ENDETH;
There was a problem uploading the updated Sieve filtering scripts,
so filtering will be disabled until you fix it via Hermes Webmail.
HERE_ENDETH
					syslog 'err', "failure updating ${user}'s scripts:" .
					    " auto: $auto; sieve: $sieve";
					for my $line (@auto) {
						syslog 'err', "auto script: $line";
					}
					for my $line (@sieve) {
						syslog 'err', "sieve script: $line";
					}
					sieve_check 'SETACTIVE',
					    sieve_cmd 'SETACTIVE ""';
				}
				sieve_check 'LOGOUT', sieve_cmd 'LOGOUT';
				return 1;
			} else {
				say "Leaving it in place.";
				syslog 'info', "${user}'s auto script " .
				    " redirection to $address left in place";
				sieve_check 'LOGOUT', sieve_cmd 'LOGOUT';
				return 1;
			}
		}
		say "You have not set up a redirection action,",
		    "so nothing needs to be done about it.";
		syslog 'info', "${user}'s auto script has no redirection";
		sieve_check 'LOGOUT', sieve_cmd 'LOGOUT';
		return 1;
	} else {
		say "You have a manually maintained Sieve filtering script.";
	}
	$sieve = sieve_cmd "GETSCRIPT \"${active}\"", @sieve;
	shift @sieve; pop @sieve; # remove framing
	if (not sieve_ok $sieve) {
		say <<HERE_ENDETH;
I could not download your active Sieve filtering script.
I'll leave it in place but disable it...
HERE_ENDETH
		syslog 'info', "fallback-deactivating ${user}'s manual ${active} script";
		sieve_check 'SETACTIVE', sieve_cmd 'SETACTIVE ""';
		say "Done.";
		sieve_check 'LOGOUT', sieve_cmd 'LOGOUT';
		return 1;
	}
	for(my $i = 0; $i < @sieve; ++$i) {
		next unless $sieve[$i] =~ /\bredirect\b/i;
		my $address;
		if ($sieve[$i] !~ /\bredirect\s*"([^"]*)"\s*;/i) {
			$address = "somewhere";
		} else {
			$address = $1;
		}
		say "It looks like it might redirect email to $address.";
		if ($address ne "$user\@$from") {
			say <<HERE_ENDETH;
Your email will bounce if it subsequently ends up at $user\@$from.
Should the script be disabled so that your email is delivered on Hermes?
HERE_ENDETH
			syslog 'info', "confirming deactivation of" .
			    " ${user}'s manual ${active} script";
			unless (prompt_yn) {
				say "Leaving it in place";
				syslog 'info', "not deactivating" .
				    " ${user}'s manual ${active} script";
				sieve_check 'LOGOUT', sieve_cmd 'LOGOUT';
				return 1;
			}
		}
		say "I'll disable the script...";
		syslog 'info', "deactivating ${user}'s manual ${active} script";
		sieve_check 'SETACTIVE', sieve_cmd 'SETACTIVE ""';
		say "Done.";
		sieve_check 'LOGOUT', sieve_cmd 'LOGOUT';
		return 1;
	}
	say <<HERE_ENDETH;
It looks like it will deliver all email on Hermes.
Leaving it in place.
HERE_ENDETH
	syslog 'info', "${user}'s manual ${active} script left in place";
	sieve_check 'LOGOUT', sieve_cmd 'LOGOUT';
	return 1;
}

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

sub doit () {
	say 'Welcome to the Hermes email forwarding fixer. This service',
	    'will arrange for your @cam.ac.uk email to be delivered to',
	    'Hermes, and will remove any filter-based forwarding that',
	    'has been set up via Webmail or the Menu System.';
	my $user = prompt "Username:";
	my $pass = prompt "Password:";
	my $err = auth $user, $pass;
	if ($err) {
		err 'warning', "authentication error: $err";
		return;
	} else {
		syslog 'info', "authenticated $user";
		say "Authenticated as $user";
	}
	my @pw = getpwnam $user;
	unless (@pw) {
		err 'err', "no such user $user";
		return;
	}
	# setgid, setuid
	$) = "$pw[3] $pw[3]";
	$( = $pw[3];
	$> = $pw[2];
	$< = $pw[2];
	my $home = $pw[7];
	# where is the user coming from?
	say "Which system are you migrating from?";
	my $from = prompt "Migrating from:";
	# which machine is the user on?
	say "Checking your Hermes forwarding setup...";
	my $machine = cdbget $CYRUSMAP, $user;
	if ($machine) {
		say "Your account is on the new Hermes machine $machine.";
		syslog 'info', "$user is on $machine";
		defined eval {
			fixfwd_new $user, $pass, $machine, $from;
		} or do {
			err 'err', "fixfwd_new: $@";
			return;
		}
	} else {
		say "Your account is on the old Hermes system.";
		syslog 'info', "$user is on old Hermes";
		defined eval {
			fixfwd_old $user, $home, $from;
		} or do {
			err 'err', "fixfwd_old: $@";
			return;
		}
	}
	# do cammail update
	say "Checking your \@cam forwarding setup...";
	my $cammail = cammail "show $user";
	return if not defined $cammail;
	if (-1 !=  index $cammail, "$user\@hermes.cam.ac.uk") {
		say "Your \@cam destination is already Hermes.";
		syslog 'info', "$user cammail already hermes";
	} elsif (-1 != index $cammail, "$user\@$from") {
		say "Your \@cam destination is $from.";
		say "Changing your \@cam destination to Hermes.";
		syslog 'info', "$user cammail redirection from $from to hermes";
		my $cammail = cammail "redirect add $user hermes";
		return if not defined $cammail;
	} else {
		say "Your \@cam destination is neither Hermes nor $from.",
		    "Do you want your \@cam email sent to Hermes?";
		syslog 'info', "confirming $user cammail redirection change";
		if (prompt_yn) {
			syslog 'info', "$user cammail redirection changed to hermes";
			my $cammail = cammail "redirect add $user hermes";
			return if not defined $cammail;
		} else {
			syslog 'info', "$user cammail redirection unchanged";
			say "Leaving your \@cam destination alone.";
		}
	}
	# finished
	say "Remote redirection updates completed OK.";
	syslog 'info', "$user finished";
}

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

#$Sys::Hostname::host = 'cyan.csi.cam.ac.uk';
#Sys::Syslog::setlogsock 'unix';

openlog $LOGID, "pid,ndelay,nowait", $LOGFAC;

# set up listening socket
check "socket", socket LISTEN, PF_INET, SOCK_STREAM, 0;
check "setsockopt", setsockopt LISTEN, SOL_SOCKET, SO_REUSEADDR, pack "l", 1;
check "bind", bind LISTEN, sockaddr_in $PORT, INADDR_LOOPBACK;
check "listen", listen LISTEN, SOMAXCONN;

# daemonize
unless ($d) {
	exit if check "fork", fork;
	check "setsid", setsid > 0;
	check "chdir /", chdir "/";
	check "open $PIDFILE", open PIDFILE, "> $PIDFILE";
	print PIDFILE getpid, "\n";
	check "close $PIDFILE", close PIDFILE;
	check "open /dev/null", open STDIN, "</dev/null";
	check "open /dev/null", open STDOUT, ">/dev/null";
	check "open /dev/null", open STDERR, ">/dev/null"
}

# a bit of signal handling
sub handle_CHLD {
	$SIG{CHLD} = \&handle_CHLD;
	debug "reaped", wait;
}
sub handle_HUP {
	$SIG{HUP} = \&handle_HUP;
	close LISTEN;
	unless (exec $PROG) {
		syslog 'alert', "exec $PROG: %m";
		die "exec $PROG: $!\n";
	}
}
$SIG{CHLD} = \&handle_CHLD;
$SIG{HUP} = \&handle_HUP;
# ensure no signals are blocked
# (which may be the case after the SIGHUP handler has re-execed us)
sigprocmask SIG_SETMASK, POSIX::SigSet::new, POSIX::SigSet::new;

# main loop
syslog 'info', "started $0";
debug "started";
for (;;) {
	my $peer = accept CLIENT, LISTEN;
	next unless $peer;
	my $pid = fork;
	if ($pid < 0) {
		err 'alert', "fork: %m";
		close CLIENT;
	} elsif ($pid) {
		# parent
		debug "child pid $pid";
		close CLIENT;
	} else {
		# child
		closelog;
		openlog $LOGID, "pid,ndelay,nowait", $LOGFAC;
		debug "new child";
		$SIG{CHLD} = 'DEFAULT';
		close LISTEN;
		autoflush CLIENT 1;
		open STDERR, ">&CLIENT" unless $d;
		autoflush STDERR 1;
		doit;
		close CLIENT;
		debug "exiting";
		exit;
	}
}

# eof
