#! /usr/bin/perl

# $Id: update 37934 2012-10-04 12:57:06Z wsl $
# $URL: https://svn.uvt.nl/its-id/trunk/sources/kiki/bin/update $

use strict;
use warnings FATAL => 'all';

use DBI;
use Encode;
use IO::File;

my $dsn = $ENV{DSN} // 'dbi:Pg:dbname=kiki';
my $user = $ENV{DBUSER} // 'kiki';
my $pass = $ENV{DBPASS};
my $options = {
	PrintError => 0,
	RaiseError => 1,
	AutoCommit => 0,
	ShowErrorStatement => 1,
	pg_enable_utf8 => 1
};

my $idmdb_file = "idmdb";

my @pita = (780251, 523090, 488937, 536001);

my %mailhosts = (
	campus => 'email.campus.uvt.nl',
	tncampus => 'email.campus.uvt.nl',
);

unless(my $result = do $idmdb_file) {
	die "Couldn't parse $idmdb_file: $@" if $@;
	die "Couldn't read $idmdb_file: $!\n" unless defined $result;
	die "Couldn't run $idmdb_file\n";
}

my @idmheaders = qw(anr uid mail alias domain mailer);
my %idmlower; @idmlower{qw(uid domain mailer)} = ();
my %idmempty; @idmempty{qw(alias)} = ();

my $db = DBI->connect($dsn, $user, $pass, $options);
my $idmdb = DBI->connect(our $idmdb_dsn, our $idmdb_user, our $idmdb_pass, $options);

BEGIN {
	if(-t STDOUT) {
		eval q[sub notice { warn(map { "$_\n" } @_) if @_; return }];
	} else {
		eval q[sub notice { return }];
	}
}

sub perform {
	my $q = $db->prepare_cached(shift);
	$q->execute(@_);
	$q->finish;
}

sub query {
	my $q = $db->prepare_cached(shift);
	$q->execute(@_);
	my $res = $q->fetchall_arrayref;
	$q->finish;
	return $res;
}

my %case;
my %domains;

sub wellformed {
	local $_;
	foreach(@_) {
		return 0 unless
			/
				^
					[a-z_][a-z_0-9]*(?:[.-][a-z_0-9]+)*
				@
					(?:(?:[a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]+|localhost)
				$
			/ixo;
	}
	return 1;
}

sub idmformed {
	local $_;
	foreach(@_) {
		return 0 unless wellformed($_.'@example.com');
	}
	return 1;
}

sub uniq {
	my %uniq;
	local $_;
	@uniq{map { lc } @_} = @_;
	return values %uniq;
}

sub unjoin {
	my $sep = shift;
	my $str = shift;
	my @res = split(/\Q$sep/, $str.$sep.chr(ord($sep)+1));
	pop @res;
	return @res;
}

my %people;

sub processidmrecord {
	my $idmline = join(';', @_);

	my %record;
	@record{@idmheaders} = @_;

	while(my ($k, $v) = each(%record)) {
		$v //= '';
		if($v eq '' && !exists $idmempty{$k}) {
			warn "Empty field '$k' in IDM record:\t$idmline\n";
			return;
		}
		$record{$k} = lc $v
			if exists $idmlower{$k};
	}

	my $anr = $record{anr};
	my $uid = $record{uid};
	my $mail = $record{mail};
	my $alias = $record{alias};
	my $domain = $record{domain};
	my $mailer = $record{mailer};

	die "Invalid mailer 'NUL' in input\n" if $mailer eq 'nul';

	if(index($mail, '@') != -1) {
		my ($local, $domain) = split('@', $mail, 2);
		if(lc($domain) eq 'uvt.nl') {
			warn "Stripping \@uvt.nl from alias in IDM record:\n\t$idmline\n";
			$mail = $local;
		} else {
			warn "IDM record trying to create an alias outside uvt.nl domain; skipped:\n\t$idmline\n";
			return;
		}
	}

	my $host = $mailhosts{$mailer} // "$mailer.uvt.nl";
	my $key = lc($mail);

	if(!idmformed($mail)) {
		my $printablemail = encode('ascii', $mail, Encode::FB_PERLQQ);
		my $printableline = encode('ascii', $idmline, Encode::FB_PERLQQ);
		warn "IDM address $printablemail not well-formed in IDM record; skipped:\n\t$printableline\n";
		return;
	}
	if($alias ne '' && !idmformed($alias)) {
		my $printablemail = encode('ascii', $alias, Encode::FB_PERLQQ);
		my $printableline = encode('ascii', $idmline, Encode::FB_PERLQQ);
		warn "IDM alias $printablemail not well-formed in IDM record; ignored:\n\t$printableline\n";
		$alias = '';
	}

	my $p = $people{$anr} //= {};
	$p->{uid} = $uid;
	$p->{canonical} = $mail;
	$p->{destination} = "$uid\@$host";
	$p->{domain} = $domain;
	my $f = $p->{func} //= [];
	push @$f, $alias if $alias ne '';
}

sub readidmfile {
	my $res = $idmdb->selectall_arrayref('SELECT anr, usernaam, mailnaam, mailnaamalias, domein, mailer FROM emailadres WHERE mailer IS NOT NULL ORDER BY mtime DESC, anr ASC');

	my $num = @$res;
	die "Too few records in IDM database ($num < 10000)\n"
		if $num < 10000;

	foreach my $record (@$res) {
		processidmrecord(map { $_ // '' } @$record);
	}
}

readidmfile;

my %names;
my %names_case;

while(my ($anr, $p) = each(%people)) {
	my $domain = $p->{domain};
	my @uniq = uniq($p->{uid}, $p->{canonical}, @{$p->{func}});
	foreach my $a (@uniq) {
		my $alias = "$a\@$domain";
		my $alias_lc = lc($alias);
		$names_case{$alias_lc} = $alias;
		my $other = $names{$alias_lc};
		die "Address $alias used for both $anr and $other\n"
			if defined $other and $other != $anr;
		$names{$alias_lc} = int($anr);
	}
}

my %existing_names;
my %existing_names_case;

do {
	my $res = query('SELECT m.person, m.name, n.name
		FROM mail_aliases m
		JOIN domains d USING (domain)
		JOIN domainnames n ON d.main = n.domainname
		WHERE m.person IS NOT NULL');
	foreach my $r (@$res) {
		my ($anr, $name, $domain) = @$r;
		my $email = "$name\@$domain";
		my $email_lc = lc $email;
		$existing_names{$email_lc} = int($anr);
		$existing_names_case{$email_lc} = $email;
	}
};

my %existing_people;

do {
	my $res = query('SELECT p.person, m.name, n.name
		FROM persons p
		JOIN mail_aliases m ON m.mail_alias = p.canonical
		JOIN domains d ON d.domain = m.domain
		JOIN domainnames n ON n.domainname = d.main');
	foreach my $r (@$res) {
		my ($anr, $canon_name, $canon_domain) = @$r;
		$existing_people{$anr} = "$canon_name\@$canon_domain";
	}
};

my %existing_destinations;

do {
	my $res = query('SELECT p.person, m.name, n.name, p.mailaddress
		FROM persons p
		JOIN mail_aliases m ON m.mail_alias = p.canonical
		JOIN domains d ON d.domain = m.domain
		JOIN domainnames n ON n.domainname = d.main');
	foreach my $r (@$res) {
		my ($anr, $name, $domain, $destination) = @$r;
		my $canonical = "$name\@$domain";
		my $p = $existing_people{$anr}
			or die "Found personal destination $destination for $anr but $anr is not in the persons table\n";
		if(exists $existing_destinations{$anr}) {
			$existing_destinations{$anr} = 'multiple values';
		} elsif(lc($p) ne lc($canonical)) {
			$existing_destinations{$anr} = 'destination attached to different alias';
		} else {
			$existing_destinations{$anr} = $destination;
		}
	}
};

while(my ($anr, $p) = each(%people)) {
	unless(exists $existing_people{$anr}) {
		notice("create $anr ($p->{destination})");
		perform('SELECT create_person(?, ?)', $anr, $p->{destination});
	}
}

while(my ($name, $anr) = each(%names)) {
	if(exists $existing_names{$name}) {
		if($existing_names{$name} == $anr) {
			if($existing_names_case{$name} ne $names_case{$name}) {
				notice("tweak $existing_names_case{$name} to $names_case{$name}");
				perform('SELECT tweak_alias(?, ?)', $existing_names_case{$name}, $names_case{$name});
			}
		} else {
			notice("move $name from $existing_names{$name} to $anr");
			perform('SELECT create_personal_alias(?, ?)', $anr, $names_case{$name});
		}
	} else {
		notice("create $name for $anr");
		perform('SELECT create_personal_alias(?, ?)', $anr, $names_case{$name});
	}
}

while(my ($anr, $p) = each(%people)) {
	my $domain = $p->{domain};
	my $canonical = lc "$p->{canonical}\@$domain";
	if($canonical ne lc $existing_people{$anr}) {
		notice("update $anr to set canonical to $canonical (destination $p->{destination})");
		perform('SELECT set_canonical_alias(?, ?)', $anr, $canonical);
	}
}

while(my ($anr, $destination) = each(%existing_destinations)) {
	if(my $p = $people{$anr}) {
		if($p->{destination} ne $destination) {
			notice("update destination for $anr from $destination to $p->{destination}");
			perform('SELECT set_personal_destination(?, ?)', $anr, $p->{destination});
		}
	}
}

while(my ($name, $anr) = each(%existing_names)) {
	unless(exists $names{$name}) {
		notice("remove $name from $anr");
		perform('SELECT remove_personal_alias(?, ?)', $anr, $name);
	}
}

while(my ($anr, $p) = each(%existing_people)) {
	unless(exists $people{$anr}) {
		notice("remove $anr ($p)");
		perform('SELECT remove_person(?)', $anr);
	}
}

perform('UPDATE persons SET pita = FALSE WHERE pita');
foreach my $anr (@pita) {
	perform('UPDATE persons SET pita = TRUE WHERE person = ?', $anr);
}

$db->commit;
#$db->rollback;
$idmdb->rollback;
