#!/usr/local/bin/perl
#
#Script to report on over/under usage of projects
#Expected to be run from cron job
use strict;
use warnings;

use lib "/cell_root/software/HPCC/lib/site_perl";

use Glue::HPCC::Cluster;

use Glue::HPCC::ProjectUsage;

use Glue::HPCC::Project::Project;
use Glue::HPCC::Project::ProjectType;
use Glue::HPCC::Project::Person;
use Glue::HPCC::Project::PersonProject;
use Glue::HPCC::Project::LastEmail;

use Getopt::Long;
use Time::ParseDate;
use POSIX qw(strftime);


my $DEBUG;
my $DEFAULT_OVER_THRESHOLD=0.15;
my $DEFAULT_UNDER_THRESHOLD=1.0;

sub usage()
{	
	print STDERR <<EOF;
$0: Cron job to warn about over/under usage of projects

Usage:
$0 [ --debug ] [ -[no]mail ] [ -type PROJTYPE ] [ -project PROJECT ] 

For all projects specified, we check the usage of the project and alert
if project rate of consumption is excessively over or under the nominal
rate.  If no PROJTYPEs or PROJECTs given, all active projects will be
examined.  Otherwise only the specifically named PROJECTs or projects
of one of the types listed will be examined.  (If both PROJTYPE and PROJECTS
given, only the intersection is considered).

Each project has its own over/underusage threshold (and if not set, they
default to $DEFAULT_OVER_THRESHOLD/$DEFAULT_UNDER_THRESHOLD, respectively);
an alert is raised if the fraction of the allocation used is more/less than
this threshold different from the fraction of the timeperiod that has passed.

If --mail is set, the pocs of the project will be sent email (subject to
LastMail filtering to avoid sending too frequently).

EOF
}

sub dump_project_usage($;$)
#Takes a list ref of Glue::HPCC::ProjectUsage records for a given
#project, and dumps them if verbose mode or any of the over/under usage
#flags set.
{	my $puarry = shift;
	my $options = shift || {};
	my $me = 'dump_project_usage';

	unless ( $puarry && ref($puarry) eq 'ARRAY' )
	{	if ( ref($puarry) eq 'Glue::HPCC::ProjectUsage' )
		{	$puarry = [ $puarry ];
		} else
		{	die "$me: Illegal value '$puarry' for ProjectUsage array.\n";
		}
	}

	my $i=0;
	my $pu;
	my $flag = 0;
	foreach $pu (@$puarry)
	{	$i++;
		die "$me: Illegal value '$pu' as element $i of puarry, need Glue::HPCC::ProjectUsage\n"
			unless $pu && ref($pu) eq 'Glue::HPCC::ProjectUsage';
		$flag = 1 if $pu->overusage_flag;
		$flag = 1 if $pu->underusage_flag;
	}
	
	my $verbose = delete $options->{verbose};
	if ( %$options )
	{	my @tmp = keys %$options;
		my $tmp = join ', ', @tmp;
		die "$me: Unrecognized option flags: [$tmp], aborting.\n";
	}

	return unless $verbose || $flag;

	#OK, we should print something
	#The following stuff should be common to all PUs in puarry
	$pu = $puarry->[0];

	my $pname = $pu->name;
	my $ptname = $pu->ptname;
	my $tstamp = $pu->tstamp_now;
	my $timenow = strftime "%Y %b %d", localtime($tstamp);
	my $over_thr = sprintf "%0.1f%%", 100*$pu->over_thr;
	my $under_thr = sprintf "%0.1f%%", 100*$pu->under_thr;

	print STDERR <<EOF;
Project: $pname
Time: $timenow
Overquota Threshold: $over_thr
Underquota Threshold: $under_thr
EOF

	my $fmt = "%-15s %-10s (%7s into) %-12s %-12s %-7s\n";
	printf STDERR $fmt, '------', 'TimePeriod', 'percent', 'Allocation', 'Available', 'PctUsed';

	my @alerts = ();

	foreach $pu (@$puarry)
	{	my $desc = $pu->description;
		my $tperiod = $pu->timeperiod;
		my $tpfrac = sprintf "%0.1f%%", 100*$pu->frac_tperiod;
		
		my $ksu_total = sprintf "%0.3f kSU", $pu->ksu_total;
		my $ksu_used = sprintf "%0.3f kSU", $pu->ksu_used;
		my $ksu_avail = sprintf "%0.3f kSU", $pu->ksu_avail;
		my $pctused = sprintf "%0.1f%%", 100*$pu->frac_used;

		printf STDERR $fmt, $desc, $tperiod, $tpfrac, $ksu_total, $ksu_avail, $pctused;

		push @alerts, "*** Excessive rate of consumption for $desc!\n"
			if $pu->overusage_flag;
		push @alerts, "$desc being consumed very slowly\n"
			if $pu->underusage_flag;
	}

	print STDERR "\n", (join '', @alerts), "\n" if @alerts;
}


#-------------------------------------------------------------------
#		Main
#-------------------------------------------------------------------

my $help;
my $ptypes = [];
my $projects = [];
my $cluster;
my $domail = 0;

my $res = GetOptions(
	'help!' => \$help,
	'debug!' => \$DEBUG,
	'mail!' => \$domail,
	'cluster=s' => \$cluster,
	'project=s' => $projects,
	'type|projtype|ptype=s' => $ptypes,
	
);

unless ( $res ) 
{	usage;
	die "\nError processing options.\n";
}
if ( $help )
{	usage;
	exit 0;
}

if ( scalar(@ARGV) )
{       if ( scalar(@$projects) == 0 )
        {       #Allow user to omit --project
                $projects = [ @ARGV ];
        } else
        {       my $tmp = join ", ", @ARGV;
                usage;
                die "\nError: extraneous arguments [ $tmp ], aborting\n";
        }
}

#Default cluster if needed
my $hpc = Glue::HPCC::Cluster->new_from_clustername($cluster);
die "\nInvalid cluster $cluster at " if $cluster && ! $hpc && ! ref($hpc);
die "\nError instantiating cluster $hpc " unless $hpc && ref($hpc);
$cluster = $hpc->db_clustername;

#Get all project entries
my $projs = Glue::HPCC::Project::Project->pdb_query($hpc);
die "No projects found.  Error???? at " unless $projs;
die "Error looking up projects: $projs at " unless ref($projs);

#Restrict to active projects
my @projs = grep { $_->active } @$projs;

#If a specific project list given, restrict to those
if ( $projects && ref($projects) eq 'ARRAY' && @$projects )
{	my %temp = map { $_ => undef } @$projects;
	print STDERR "Restricting to projects: [",
		(join ", ", @$projects), "]\n" if $DEBUG;

	@projs = grep { exists $temp{$_->name} } @projs;
}

#If specific project types given, restrict to those
if ( $ptypes && ref($ptypes) eq 'ARRAY' && @$ptypes )
{	my @temp = map { Glue::HPCC::Project::ProjectType->projecttype_by_name(
			$hpc, $_) } @$ptypes;
	my %temp = map { $_->pkey => undef } @temp;

	print STDERR "Restricting to project types : [",
		(join ", ", @$ptypes), "]\n" if $DEBUG;

	@projs = grep { exists $temp{$_->projtype} } @projs;
}

#Now check each project
PROJECT: foreach my $proj (@projs)
{	my $pname = $proj->name;
	my $ptypeid = $proj->projtype;
	my $ptype =  Glue::HPCC::Project::ProjectType->projecttype_by_pkey(
		$hpc, $ptypeid);
	my $ptname = $ptype->name;
	print STDERR "Checking project $pname ($ptname) ..." if $DEBUG;

	my ($pulist, $pusage, $pusage_hi);
	my $macros = {};
	my $template;
	my $desc;

	if ( $ptname eq 'coop' )
	{	$pulist = Glue::HPCC::ProjectUsage->check_coop_project_usage(
			hpc => $hpc,
			cluster => $cluster,
			project => $proj,
		);

		unless ( $pulist && ref($pulist) eq 'ARRAY' )
		{	warn "Error checking usage of  $pname [$pulist]\n";
			next PROJECT;
		}

		($pusage_hi, $pusage) = @$pulist;

		if ( $pusage_hi->overusage_flag || $pusage->overusage_flag )
		{	$template = "${cluster}_excessive_usage_coop.tmplate";
			$macros->{PUSAGE_HIGH} = $pusage_hi;
			$macros->{PUSAGE_TOTAL} = $pusage;
			$desc = "Overusage on ${pname}-hi";
			$desc = "Overusage on ${pname} (total)" 
				if $pusage->overusage_flag;
		} elsif ($pusage_hi->underusage_flag || 
			$pusage->underusage_flag)
		{	$template = "${cluster}_under_usage_coop.tmplate";
			$macros->{PUSAGE_HIGH} = $pusage_hi;
			$macros->{PUSAGE_TOTAL} = $pusage;
			$desc = "Underusage on ${pname}-hi";
			$desc = "Underusage on ${pname} (total)" 
				if $pusage->underusage_flag;
		} else
		{	#No alerts, go to next
			print STDERR " no issues for $pname\n" if $DEBUG;
			next PROJECT;
		}
	} else
	{	print STDERR " type $ptname not supported\n" if $DEBUG;
		warn "Do not know how to handle ptype $ptname: skipping $pname\n";
		next PROJECT;
	}

	print STDERR " alerts for $pname\n" if $DEBUG;
	#Have an alert: $macros and $template are set
	#Get all PoCs for this project
	my $pocs = Glue::HPCC::Project::PersonProject->get_pocs_for_project(
		$hpc, $pname);
	unless ( $pocs && ref($pocs) eq 'ARRAY' )
	{	warn "Error getting pocs for $pname: $pocs, skipping";
		next PROJECT;
	}

	if ( $domail )
	{   #Send email to the PoCs, subject to LastEmail frequency
	    POC: foreach my $poc (@$pocs)
	    {	my $err = 
		    Glue::HPCC::Project::LastEmail->nospam_send_template_email(
		 	hpc => $hpc,
			username => $poc,
			project => $pname,
			account => $pname,
			mailcode => 'usage-warning',
			description => $desc,
			template => $template,
			macros => $macros,
		);
		warn "Error sending '$desc' warning to $poc: $err\n"
			if $err;
		next POC;
	    }
	    next PROJECT;
	} else
	{    	#Just print to STDERR
		print STDERR "Warning for $pname\n";
		print STDERR "$desc\n";
		print STDERR "pocs=", (join ", ", @$pocs), "\n";
		dump_project_usage($pulist);
		next PROJECT;
	}
}
