#! /usr/bin/perl

# $Id: update 40935 2014-02-04 13:22:05Z 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 domain mailer vnr);
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 STDERR) {
		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 $_;
	return grep { !$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:\n\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 $domain = $record{domain};
	my $mailer = $record{mailer};
	my $vnr = $record{vnr};

	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 $name = "$mail\@$domain";
	my $host = $mailhosts{$mailer} // "$mailer.uvt.nl";
	my $key = lc($mail);
	my $destination = "$uid\@$host";

	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;
	}

	my $p = $people{$anr};
	if($p) {
		die "IDM record inconsistent: previous uid '$p->{uid}' differs from '$uid'.\n\t$idmline\n"
			if $p->{uid} ne $uid;
		die "IDM record inconsistent: previous destination '$p->{destination}' differs from '$destination'.\n\t$idmline\n"
			if $p->{destination} ne $destination;
		die "IDM record inconsistent: slot $vnr for '$name' already occupied by '$p->{names}[$vnr]'.\n\t$idmline\n"
			if defined $p->{names}[$vnr];
	} else {
		$p = $people{$anr} = {
			uid => $uid,
			names => [],
			destination => $destination,
		};
	}
	$p->{names}[$vnr] = $name;
}

sub readidmfile {
	my $res = $idmdb->selectall_arrayref('SELECT anr, usernaam, mailnaam, domein, mailer, vnr FROM emailadres_new WHERE mailer IS NOT NULL ORDER BY mtime DESC, anr ASC, vnr 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 $names = $p->{names};
	while(my ($vnr, $name) = each(@$names)) {
		die "Alias #$vnr missing for $p->{uid} ($anr)\n"
			unless defined $name;
	}
	push @$names, $p->{names}[0] =~ s/^[^@]+/$p->{uid}/r;
	my @uniq = uniq(@$names);
	foreach my $alias (@uniq) {
		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 $canonical = lc $p->{names}[0];
	if(!exists $existing_people{$anr} || $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;
$idmdb->rollback;
