#!/usr/bin/perl
#
# $Cambridge: hermes/conf/exim/sbin/stats_spam,v 1.10 2008/08/21 16:42:52 fanf2 Exp $

use strict;
use warnings;

use POSIX;

if (@ARGV != 1) {
	die "usage: $0 <log number>\n";
}

my $day = $ARGV[0];
my $date = strftime "%Y-%m-%d", localtime (time - $day * 86400);
my $file = sprintf "/spool/exim/log/mainlog.%02d", $day;
my $cmd = $day > 1 ? "zcat $file.gz" : "cat $file";

# table mapping users to institution codes
my %hermes;
open my $hn, "/opt/dist/users/hermes_nodeid"
or die "open /opt/dist/users/hermes_nodeid: $!\n";
while (<$hn>) {
	next unless /^(\S+)\s+(\S+)$/;
	$hermes{$1} = $2;
}
close $hn;

# table mapping users to domains
my %cam;
open my $cd, "/opt/dist/users/cam_aliases"
or die "open /opt/dist/users/cam_aliases: $!\n";
while (<$cd>) {
	next unless /^([^:]*):[^@]*@(\S+)$/;
	$cam{$1} = $2;
}
close $cd;

my %total;
my %node;
my %domain;
my %overlap;
my %list;

# fixed set of list prefixes
for my $prefix (qw( aerial african alumni ames arch archanth arct asnc
		ast bioanth bioc biology biophy biotech biowire
		botanic bpi brc bs bssphy caius camcors campop camsis
		cao caret casc caths cbr cbs ceb cec cerf cfr chem
		chemlabs cheng chris christs chu ciao cilr cimr citmg
		cl clare clarehall clas classics cmeis cms conted
		corpus counselling crassh cri crim cs cscr cshss ctf
		cure cusu damtp dar devstudies ditmg divinity dow eai
		econ educ emma eng english esc fitz fitzmuseum french
		geog girton gurdon haddon haem history hki hoart hom
		hpc hpcf hps hughes hutchison infectiousdisease
		intstudies iph jbs jesus joh johns kettles kings
		landecon latin law lcc lib ling magd mailman
		margaretbeaufort maths mcdonald medic medschl mic mml
		mrc msm mus nano neuro newhall newn newnham obgyn
		oriental path pathology pdn pem personnel pet phar
		phil phpc phy physics pom prayer psychiatry psychol
		quen rceal ridley robinson safety security sel sid soc
		socanth special spri sps st stedmunds sucon talks test
		trin trinhall trophoblast ucam unicen unite varsity
		vet vhi westcott wolfson woolfinstitute zoo )) #)
{
	$list{$prefix} = {};
}

sub count ($$$) {
	my $user = lc shift;
	my $domain = lc shift;
	my $reason = shift;
	$total{$reason}++;
	if ($domain eq "srcf.ucam.org"
	    and $user =~ /^([a-z]+[0-9]+)-/
	    and exists $hermes{$1}) {
		$user = $1;
	}
	if ($domain eq "cl.cam.ac.uk"
	    and $user =~ /[+]([a-z]+[0-9]+)$/
	    and exists $hermes{$1}) {
		$user = $1;
	}
	if ($domain eq "hermes.cam.ac.uk"
	    and $user =~ /^([a-z]+[0-9]*)[+]/) {
		$user = $1;
	}
	if (exists $hermes{$user}) {
		$node{$hermes{$user}}{$reason}++;
	}
	if ($domain eq "cam.ac.uk" and exists $cam{$user}) {
		$domain = $cam{$user};
	}
	if ($domain =~ /^( ([a-z0-9.-]+[.])?cam[.]ac[.]uk
                         | cambridge[.]org
                         | srcf[.]ucam[.]org )$/x) {
		$domain{$domain}{$reason}++;
		if (exists $hermes{$user}) {
			$overlap{$hermes{$user}."@".$domain}{$reason}++;
		}
	}
	if ($domain eq "lists.cam.ac.uk"
	    and $user =~ /^([a-z]+)-/
	    and exists $list{$1}) {
		$list{$1}{$reason}++;
	}
}

open my $log, "$cmd |"
    or die "open $file: $!\n";

while (<$log>) {
	my $local = / H=[^ ]*[.]cam[.]ac[.]uk /;
	if (/Warning:( spam score (\S+) | message is infected )|( <= )/) {
		my $reason;
		if (defined $3) {
			if (/ I=[[]131[.]111[.]8[.]15/) {
				$reason = "ok-her";
			} else {
				$reason =
				    $local ? "ok-int" : "ok-ext";
			}
		} elsif (not defined $2) {
			$reason = "virus";
		} elsif ($2 >= 10) {
			$reason = "spam-hi";
		} elsif ($2 >= 5) {
			$reason = "spam-lo";
		} else {
			next;
		}
		/ for (.*)/;
		for my $addr (split /\s+/, $1) {
			$addr =~ /^([^@]*)@([^>]*)$/;
			count $1, $2, $reason;
		}
		next;
	}
	if ($local) {
		next;
	}
	if (/ rejected RCPT <([^@]*)@([^>]*)>: /) {
		my $user = $1;
		my $domain = $2;
		my $reason = "badrcpt";
		if (/ \S* is listed at \S*; /) {
			$reason = "dnsbl";
		} elsif (/Could not complete sender verify/ or
			 /Sender verify failed/) {
			$reason = "badfrom";
		} elsif (/Relaying is not permitted/ or
			 /Polite people say HELO first/ or
			 /Please use your name when saying HELO/ or
			 /No SMTP service for unauthorized users/ or
			 /No SMTP service for unauthenticated users/) {
			$reason = "protocol";
		}
		count $user, $domain, $reason;
		next;
	}
	# no useful recipient information for these ones
	if (/SMTP protocol synchronization error/ or
	    /syntactically invalid argument/ or
	    /SMTP syntax error/) {
		$total{"protocol"}++;
		next;
	}
}

close $log or die "close $file: $!\n";

my $T = "    TOTAL";
sub total ($) {
	my $hash = shift;
	my $total;
	for my $key (keys %$hash) {
		$total += $hash->{$key};
	}
	$hash->{$T} = $total;
}
for my $node (keys %node) {
	total $node{$node};
}
for my $domain (keys %domain) {
	total $domain{$domain};
}
for my $pair (keys %overlap) {
	total $overlap{$pair};
}
for my $prefix (keys %list) {
	total $list{$prefix};
}
total \%total;

my @keys = sort keys %total;

my $width = 0;
for my $pair (keys %overlap) {
	$width = length $pair if $width < length $pair;
}

sub line ($$) {
	my $key = shift;
	my $hash = shift;
	return unless $hash->{$T};
	printf "$date  %".$width.'s', $key;
	for my $key (@keys) {
		printf '  %'.(length $key).'d', ($hash->{$key} or 0);
	}
	print "\n";
}
print "$date  ".(join "  ", (" "x$width), @keys)."\n";

sub hash ($) {
	my $hash = shift;
	for my $key (sort {
		($hash->{$b}->{$T} or 0) <=> ($hash->{$a}->{$T} or 0)
	} keys %$hash) {
		line $key, $hash->{$key};
	}
}

line 'TOTAL', \%total;
hash \%domain;
hash \%node;
hash \%overlap;
hash \%list;
