#!/usr/local/bin/perl  -w

# Copyright (c) 2002                            RIPE NCC
#
# All Rights Reserved
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted,
# provided that the above copyright notice appear in all copies and that
# both that copyright notice and this permission notice appear in
# supporting documentation, and that the name of the author not be
# used in advertising or publicity pertaining to distribution of the
# software without specific, written prior permission.
#
# THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS; IN NO EVENT SHALL
# AUTHOR BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY
# DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
# AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

#------------------------------------------------------------------------------
# Module Header

# TODO: revisit 'relative diff' computation, also color 0 -> 100 changes
# TODO: seperate marking for delays and Loss ?

#
# Data structure:

# testbox hash

# box {$shortname} {'incoming'}{'short2.5per'}

# Sort on:
#		minimum, median, maximum, loss  [in|out]
#		absolute change, relative change, value 
#		descending / ascending  (absolute values)

use strict;
use XML::DOM;
use CGI;

my $progname = $ENV{'SCRIPT_NAME'} || "dummy";

my %box;				# hash with testbox summary data
my %param;				# hash with additional parameters
my @boxlist = ();			# sorted list of testbox names
my $red="#ff2222";			# color definitions
my $green="#22ff22";

my %default;
my %ttInfo;  # info on box location and hosting organisation

my @classes = ("incoming", "outgoing");
my @fieldlist = ("perc2.5" , "Median", "perc97.5", "Loss");

#### Main routine

{


my ($name, $class, $field, $value);
my ($sortclass, $sortfield, $sortorder);
my $threshold;				#  < 0  sort on absolute diffs
					#  = 0  sort on value
					#  > 0  sort on relative diffs

$default{'file'}      = "summary.xml";
$default{'format'}    = "html";
$default{'sortfield'} = "name";
$default{'sortkey'}   = "value";
$default{'sortorder'} = "ascending";
$default{'threshold'} = "40";
$default{'unit'}      = "percent";
$default{'boxname'}   = "tt01";
$default{'ipv'}       = "4";

# temporary, until we get the names from XML file 

my @GPSINFO = `cat /ncc/www/publish/pub/ripencc/mem-services/ttm/Plots/GPSINFO`;
chomp @GPSINFO;
foreach my $f (@GPSINFO) {

    # is this a status line?
    if (! ($f =~ /^status:\t(\w+)$/)) {
        my ($name, $lat, $long, $place) = split ('\t', $f);
	my ($org, @location) = split (/,/, $place);
	my $location = join(",", @location);
        $ttInfo{$name}{'location'}  = $location;
        $ttInfo{$name}{'org'} = $org;
        $ttInfo{$name}{'place'} = $place;
    }
}


# get parameters;

my $query = new CGI;

$param{'file'}      = $query->param('file')      || $default{'file'};
$param{'format'}    = $query->param('format')    || $default{'format'};
$param{'boxname'}   = $query->param('boxname')   || $default{'boxname'};
$param{'sortorder'} = $query->param('sortorder') || $default{'sortorder'};
$param{'sortfield'} = $query->param('sortfield') || $default{'sortfield'};
$param{'sortkey'}   = $query->param('sortkey')   || $default{'sortkey'};
$param{'unit'}      = $query->param('unit')      || $default{'unit'};
$param{'ipv'}       = $query->param('ipv')       || $default{'ipv'};

# can't use above constructs for 'threshold' field because '0' is valid value
if (! defined $query->param('threshold')) {
	$param{'threshold'} = $default{'threshold'};
}
else {
	$param{'threshold'} = $query->param('threshold');
}


# sanity check: no special chars in filename, only words
# (i.e. alphanumeric + '_') are allowed, optionally seperated by '.' 

if (! ($param{'file'} =~ /^(\w\.*){1,}$/)) {
	&abort ("$param{'file'} - Invalid characters in filename");
}

my $prefix="";
my $ipversion = $param{'ipv'} || "4" ;
if ($ipversion == 6) {
	$prefix = "IPv6.";
}
	

my $filename = "$param{'boxname'}/$prefix$param{'file'}";

if ((! -f $filename) ||  (! -r $filename) ){
	abort("cannot open file $filename");
}

# sanity check: threshold is a (optionally floating point) number
if (! ($param{'threshold'} =~ /^\s*\d+\.*\d*\s*$/)) {
	&abort ("$param{'threshold'} - Not a number");
}

if ($param{'unit'} eq "percent") {
	# absolute change in value 
	$threshold = $param{'threshold'} / 100;
}
elsif ($param{'unit'} eq "miliseconds") {
	$threshold = -$param{'threshold'};
}
else {
	abort("$param{'unit'} - unknown unit for change field");
}


my $change;
if ($param{'$sortkey'} eq "absolute change") {
	$change = -1;
}
elsif ($param{'sortkey'} eq "relative change") {
	$change = +1;
}
else {
	# sort on the shorterm value
	$change=0;
}

if ($param{'format'} eq "xml") {
	# no point in decoding, give it to the user as-is
	open(XML, $filename) || abort ("$filename: cannot open");
	print "Content-type: text/plain\n\n";
	while (<XML>) {
		print;
	}

	exit(0);
}

# decode XML and output in requested format

decodeXML($filename, $param{'sortfield'}, $change, $threshold, $param{'sortorder'});

if ($param{'format'} eq "html") {
	outputHTML($threshold);
}
elsif ($param{'format'} eq "ascii") {
	outputCSV($threshold);
}
else {
	abort ("$param{'format'}: Unknown output format");
}

exit(0);

}

#---------------------------------------------------------------------
# Subroutine header
#  
#  decode XML file, fill globals %box and @boxlist
#  (the ordered list of names, starting point for HTML output)
#---------------------------------------------------------------------

sub decodeXML {

	my ($filename, $sortfield, $change, $threshold, $sortorder) = @_;

	my $parser = new XML::DOM::Parser;
	my $doc = $parser->parsefile ("$filename");

	#
	# only one source in an XML file
	#

	my $nodes = $doc->getElementsByTagName ("source");
	my $node  = $nodes->item(0);	      
	my $att = $node->getAttributeNode("name");
	$param{'source'} = $att->getValue;

	#
	# fetch other parameters characterizing this summary
	#
	
	my $nodes = $doc->getElementsByTagName ("param");
	my $node  = $nodes->item(0);	      
	
	$att = $node->getAttributeNode("date");
	$param{'date'} = $att->getValue;
	
	$att = $node->getAttributeNode("period");
	$param{'period'} = $att->getValue;
	
	$att = $node->getAttributeNode("shortterm");
	$param{'shortterm'} = $att->getValue;
	
	$att = $node->getAttributeNode("longterm");
	$param{'longterm'} = $att->getValue;
	
	
	my $nodes = $doc->getElementsByTagName ("target");
	my $n = $nodes->getLength;
	
	for (my $i = 0; $i < $n; $i++)
	{
		my $node = $nodes->item ($i);
	    	$att = $node->getAttributeNode("name");
		my $name = $att->getValue;
		foreach my $class (@classes) {
	    		my $clist = $node->getElementsByTagName ($class);
			foreach my $field (@fieldlist) {
	    			my $flist = ($clist->item(0))->getElementsByTagName($field);
    				$att = ($flist->item(0))->getAttributeNode("short");
				my $value = $att->getValue;

				if ($field eq 'Loss') {
					# convert fraction to percentage
					if ($value != -1) {
						$value = $value * 100;
						$value = sprintf("%.1f", $value);
					}
				}

				$box{$name}{$class}{$field}{'short'} = $value;

    				$att = ($flist->item(0))->getAttributeNode("long");
				$value = $att->getValue;

				if ($field eq 'Loss') {
					# convert fraction to percentage
					if ($value != -1) {
						$value = $value * 100;
						$value = sprintf("%.1f", $value);
					}
				}

				$box{$name}{$class}{$field}{'long'} = $value;
			}
		}
		# insertion sort
		if ($sortfield ne "name") {
			# can't do numerical comparison on strings
			insertsort  ($name, $sortfield, $change, $threshold, $sortorder);
		}
		else {
			@boxlist = (@boxlist , $name);
		}
	}

	if ($sortfield eq "name") {
		if ($sortorder eq "descending") {
			@boxlist = sort {$b cmp $a} keys %box;
		}
		else {
			@boxlist = (sort keys %box);
		}
	}

	# Avoid memory leaks - cleanup circular references
	# for garbage collection
	$doc->dispose;

}

#---------------------------------------------------------------------
# Subroutine header
#  
#  insert new record in @boxlist, such that list remains sorte
#  (insertion sort algorithm) The sortvalue() subroutine is
#  expected to return a unique value for a given class,field
#
#---------------------------------------------------------------------
#


sub insertsort {

	my ($name, $sortfield, $change, $threshold, $sortorder) = @_;
	
	my $boxno = 0;
	my $value = sortvalue($name, $sortfield, $change, $threshold);

	BOX: while ($boxno <= $#boxlist) {
		my $temp = sortvalue($boxlist[$boxno], $sortfield, $change, $threshold);	
		if ((($sortorder eq "ascending")  && ($temp > $value)) ||
		    (($sortorder eq "descending") && ($temp < $value)))   {
			last BOX;
		}

		$boxno++;
	}

	#
	# found the right spot, now insert it
	#

	for (my $i=$#boxlist; $i >= $boxno; $i--) {
		$boxlist[$i+1] = $boxlist[$i];
	}
	
	$boxlist[$boxno]  = $name;
}

#---------------------------------------------------------------------
# Subroutine header
#  
# Purpose           : determine value to be used in sorting
# Input             : box name, sortfield, sortkey, threshold, global %box
# Output            : value which can be used in insertion sort
# Comments          : the sortkey tells what to do with the sortfield:
#		      return the value, relative change or absolute change
#		      When sorting on 'marked cells', the threshold
#		      determines if a cell is 'red', 'green' or neutral
#
#---------------------------------------------------------------------

sub sortvalue {
	my ($name, $sortfield, $sortkey, $threshold) = @_;

	my $sortclass;

	if ($sortfield eq "name") {
		return($name);
	}
	
	if ($sortfield ne "marked cells") {
		($sortclass, $sortfield) = split(/ /, $sortfield);

	        if ($sortkey == 0) {
			# return recent 'shortterm' value
			return($box{$name}{$sortclass}{$sortfield}{'short'});
		}
		elsif ($sortkey > 0) {
	        	if (($box{$name}{$sortclass}{$sortfield}{'short'} == -1) ||
	                    ($box{$name}{$sortclass}{$sortfield}{'long'} <= 0)) {
				return (-1);
			}

			# relative change between short and long

			my $diff = $box{$name}{$sortclass}{$sortfield}{'short'}
				- $box{$name}{$sortclass}{$sortfield}{'long'};
			return ($diff/$box{$name}{$sortclass}{$sortfield}{'long'});
		}
		else {
			# $change < 0  , absolute change
			my $diff = $box{$name}{$sortclass}{$sortfield}{'short'}
				- $box{$name}{$sortclass}{$sortfield}{'long'};
			return ($diff);
		}
	}
	else {
		# sort on marked cells, derive one number from 8 cell colors
		# weigth of a cell is higher if it is a parameter less
		# likely to change (2.5 percentile has highest weight)
		# also to get better grouping, incoming has slightly
		# higher weight than outgoing
		
		my $value = 0;
		my $weight = 1.1;
		foreach my $class (@classes) {
			$weight += $#fieldlist;
			foreach my $field (@fieldlist) {
				my $col = cellcolor($name, $class, $field, $threshold); 
				if ($col eq $green) {
					$value += $weight;
				}
				elsif ($col eq $red) {
					$value += 2 * $weight;
				}
				$weight--;
			}
			$weight += 0.1;
		}
		return($value);
	}
}
		
#---------------------------------------------------------------------
# Subroutine header
#
# Purpose           : create HTML output 
# Comments          : 
# Input             : threshold for coloring
#		      globals $query (CGI object) and %param hash
# Output            : HTML page
# 
#---------------------------------------------------------------------

sub outputHTML {

	my ($threshold) = @_;

	my $period = $param{'period'};

	# URL for cross reference to other box'es statistics

	my $url="${progname}?sortfield=$param{'sortfield'}&ipv=$param{'ipv'}&" .
		 "sortkey=$param{'sortkey'}&sortorder=$param{'sortorder'}&" .
		 "threshold=$param{'threshold'}&unit=$param{'unit'}";

	$url =~ s/ /+/g;

	my $boxname = $param{'boxname'};

	my $prefix = "";
	if ($param{'ipv'} == 6) {
		$prefix = "IPv6 ";
	}

	print_header("${prefix}TTM summaries for $param{'source'}" ,
		     "$ttInfo{$boxname}{'org'},$ttInfo{$boxname}{'location'}" .
		     "<BR><BR>$param{'date'}");

	print "The table below displays the TTM delay &amp; loss parameters for ";
	print "traffic received from and send to the listed test-boxes by ";
	print "$param{'source'}. ";
	print "Each cell lists both the result for the last $period as well ";
	print "as (in parentheses) the median value of this parameter for ";
	print "the preceding 10 ${period}s. If the two differ by more than ";
	print "$param{'threshold'} $param{'unit'} the background of the cell ";
	print "will be colored: ";
	print "<font color=$red>red</font> if the parameter ";
	print "increased, <font color=$green>green</font> if it decreased.";
	print "<P>\n";

	print "The table is sorted on ";

	my $sortfield = $param{'sortfield'};

	if (($sortfield ne "marked cells") && ($sortfield ne "name")) {
		if ($param{'sortkey'} ne "value") {
			print "$param{'sortkey'} in ";
		}
	}
	print "<EM>$sortfield</EM> in <EM>$param{'sortorder'}</EM> order.";
	print "These settings can be changed through the form following.";
	print "The hyperlinks take you to the pages with ";
	print "the delay plots for the last 24 hours 7 days and 30 days, ";
	print "thus providing a more detailed look at the data. ";

	outputForm($threshold);

	my $basehref = "TARGET=Plots " .
		       "HREF=plots.cgi?ipv=$param{'ipv'}&url=map_index.cgi";

	print "<TABLE WIDTH=750 BORDER=2 CELLSPACING=2 CELLPADDING=5>\n",
	      "<TR><TH></TH><TH Colspan=4>", $classes[0], "</TH><TH>",
	      "</TH><TH Colspan=4>", $classes[1], "</TH></TR>\n",
	      "<TR><TH ALIGN=LEFT>Box name, organisation<BR>location</TH><TH>2.5 perc.</TH><TH>median</TH>",
	      "<TH>97.5 perc.</TH><TH>% Lost</TH><TH>&nbsp;&nbsp;",
	      "&nbsp;&nbsp;</TH><TH>2.5 perc.</TH><TH>median</TH>",
	      "<TH>97.5 perc.</TH><TH>% Lost</TH></TR>\n";


	foreach my $name (@boxlist) {

		print "<TR ALIGN=CENTER><TD ALIGN=LEFT WIDTH=25%>" ,
		      "<A HREF=\"${url}&boxname=$name\">$name:</A>&nbsp;<FONT SIZE=-1>",
		      "$ttInfo{$name}{'org'}<BR>$ttInfo{$name}{'location'}</TD>";
		foreach my $class (@classes) {
			foreach my $field (@fieldlist) {

				# determine CELL COLOR
				my $cellcolor = cellcolor($name, $class, $field, $threshold);
			
				if ($cellcolor ne "0") {	
					print "<TD BGCOLOR=$cellcolor><A ${basehref}";
				}
				else {
					print "<TD ><A ${basehref}";
				}

				if ($class eq "incoming") {
					print "&base=${boxname}&src=${name}&dst=${boxname}>"; }
				else {
					print "&base=${boxname}&src=${boxname}&dst=${name}>";
				}

				my $value = $box{$name}{$class}{$field}{'short'};
				if ($value == -1) {	
					$value = "-";	# -1 == no data
				} 
				print $value;
				print "</A><BR>";

				$value = $box{$name}{$class}{$field}{'long'};

				if ($value == -1) {	
					$value = "&nbsp;";  # -1 == no data
				}
				print "($value)";
				print "</TD>";
			}
			print "<TD></TD>";   # seperator columns
		}
		print "</TR>";

	}

	print "</TABLE>";


}


#---------------------------------------------------------------------
# Subroutine header
#
# Purpose           : Determine a cells color, depending on the threshold
#		      and the difference between short and long term
#		      cell value. Red signifies increase in delay,
#		      green indicates decrease in delay.
# Input             : - name, class & field of current cell to retrieve
#		        value from global %box hash
#		      - threshold at which to color: 
#				0 = don't color at all
#			       >0 = color according to relative change
#			       <0 = color according to absolute change
# Output            : a HTML color attribute  (#rrggbb) or 0 (don't color)
#---------------------------------------------------------------------


sub cellcolor {
	my ($name, $class, $field, $threshold) = @_;

	my $diff;

        if (($threshold == 0) ||
	    ($box{$name}{$class}{$field}{'short'} == -1) ||
	    ($box{$name}{$class}{$field}{'long'} <= 0)) {
		# no coloring
		return(0);
	}

	if ($threshold > 0) {
		# relative change between short and long

		$diff = ($box{$name}{$class}{$field}{'short'}
				- $box{$name}{$class}{$field}{'long'});
		$diff = $diff / abs($box{$name}{$class}{$field}{'long'});

	}
	else {
		# $threshold < 0  , absolute change
		$diff = $box{$name}{$class}{$field}{'short'}
				- $box{$name}{$class}{$field}{'long'};
		$threshold = abs($threshold);
	}

	if ($diff > $threshold) {
		# new > old
		return ("$red");
	}
	elsif ($diff < -$threshold) {
		return ("$green");
	}
	else {
		# within 'normal' range
		# no coloring
		return(0);
	}
}

#---------------------------------------------------------------------
# Subroutine header
#
# Purpose           : print the HTML query form 
# Comments          : 
# Input             : global %param hash
# Output            : HTML code
# 
#---------------------------------------------------------------------

sub outputForm {

	my $value;

	print "<HR>\n";
	print "<TABLE BORDER=0>";
	print "<FORM ACTION=\"$progname\" METHOD=\"GET\">\n";

	print "<TR>\n";
	print "<TD>Sort summary table on</TD>\n";
	print "<TD><SELECT NAME=\"sortfield\">";

	my @options;
	push (@options, "name");
	push (@options, "marked cells");
	foreach my $class (@classes) {
		foreach my $field (@fieldlist) {
			push (@options, "$class $field");
		}
	}
	foreach my $i (@options) {
		if ($i eq $param{'sortfield'}) {
			print "<OPTION SELECTED>$i</OPTION>";
		}
		else {
			print "<OPTION>$i</OPTION>";
		}
	}
	print "</SELECT>\n";

	print "<SELECT NAME=\"sortkey\">";
	foreach my $i ("value", "relative change", "absolute change") {
		if ($i eq $param{'sortkey'}) {
			print "<OPTION SELECTED>$i</OPTION>";
		}
		else {
			print "<OPTION>$i</OPTION>";
		}
	}
	print "</SELECT></TD>\n";

	print "<TD><SELECT NAME=\"sortorder\">";
	foreach my $i ("ascending", "descending") {
		if ($i eq $param{'sortorder'}) {
			print "<OPTION SELECTED>$i</OPTION>";
		}
		else {
			print "<OPTION>$i</OPTION>";
		}
	}
	print "</SELECT></TD>\n";

	print "</TR><TR>\n";
	print "<TD>Threshold for coloring differences</TD>\n";
        print "<TD ALIGN=LEFT><INPUT TYPE=TEXT SIZE=5 NAME=threshold VALUE=\"" ;

	printf "%5.1f", $param{'threshold'};
	print  "\">";


	print "<SELECT NAME=\"unit\">";
	foreach my $i ("percent", "miliseconds") {
		if ($i eq $param{'unit'}) {
			print "<OPTION SELECTED>$i</OPTION>";
		}
		else {
			print "<OPTION>$i</OPTION>";
		}
	}
	print "</SELECT>\n</TD><TD></TD></TR>";

	print "<TR><TD>Output format:</TD><TD>";
	foreach ("html" , "xml", "ascii") {
                if ($_ eq $param{'format'})
                {
                        print "<INPUT TYPE=radio NAME=format VALUE=$_ CHECKED>$_
 ";
                }
                else
                {
                        print "<INPUT TYPE=radio NAME=format VALUE=$_>$_ ";
                };
        }


        print "<INPUT TYPE=HIDDEN NAME=boxname VALUE=\"$param{'boxname'}\">";
        print "<INPUT TYPE=HIDDEN NAME=file VALUE=\"$param{'file'}\">";
        print "<TD ALIGN=RIGHT><INPUT TYPE=SUBMIT NAME=SUBMIT VALUE=\"Submit\"></TD>\n";
	print "</TR>";
	print "</FORM>";
	print "</TABLE>";
	print "<HR>\n";
}

#---------------------------------------------------------------------
# Subroutine header
#
# Purpose           : create CSV Ascii output 
# Comments          : 
# Input             : globals %param hash and sorted @boxlist
# Output            : HTML page with CSV table in plain text 
# 
#---------------------------------------------------------------------

sub outputCSV {

	
	print "Content-type: text/plain\n\n";
	print "TTM summaries for $param{'source'}\n\n";

	foreach my $name (@boxlist) {

		print "$name";
		foreach my $class (@classes) {
			foreach my $field (@fieldlist) {

				my $value;
				$value = $box{$name}{$class}{$field}{'short'};
				print ",$value";

				$value = $box{$name}{$class}{$field}{'long'};
				print ",$value";
			}
		}
		print "\n";
	}
}

#---------------------------------------------------------------------
# Subroutine Header
#
# Purpose           : abort
# Comments          : 
# Input             : error message
# Output            : HTML page
#---------------------------------------------------------------------

sub abort {
        my ($message) = @_;

        &print_header("TTM summaries","");
        print "<P><FONT COLOR=RED><B>ERROR: $message</B></FONT></P>";
        &print_footer;
	exit(1);
}

#---------------------------------------------------------------------
# Subroutine Header
#
# Purpose           : print header
# Comments          : output http header + start of HTML page (title etc.)
# Input             : global %param hash
# Output            : HTML code
#---------------------------------------------------------------------

sub print_header {
	
	my ($maintitle, $subtitle) = @_;

	print "Content-type: text/html\n\n";
	
	# `cat std TTM header`

	print "<HTML><TITLE>$maintitle</TITLE><BODY>";
	print "<H1>$maintitle</H1>\n";
	print "<H2>$subtitle</H2>\n";
}

#---------------------------------------------------------------------
# Subroutine Header
#
# Purpose           : print footer
# Comments          : output end of HTML page (bottom bar etc.)
# Output            : HTML code
#---------------------------------------------------------------------

sub print_footer {

	# `cat footer`
	#
	print "</BODY></HTML>\n";
}