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

# Graph multicast beacon data
# Andrew Daviel, TRIUMF, June 2004
# mod. Sept 2004 - add "-T" taint check
# mod. Oct 2004 - use system "grep" to speed up data filtering

# requires "gnuplot"
# beacon data is saved in "history.<utime>" files by "get-next"
# for high-volume use should probably cache graphs instead of
# redrawing them every time

#Format is: Year, Month, Day, Hour, Minute, Second, S_SSRC, R_SSRC, S_SSRC IP, R_SSRC IP, Loss, RTT, Jitter

# to enable link on beacon pages, add this wrapper (and </a> around TD values around "beacon" line 720:
# print OUTFILE "<a href=\"/cgi-bin/beacon-history.png?from=$$ip_lookup{$r_ssrc}&to=$$ip_lookup{$s_ssrc}&pass=$thispass\">" ;

use Time::Local ;
#use Scalar::Util qw( tainted) ;

$expiry = 5 * 60 ; # interval between getting new files
$ENV{PATH}='/usr/bin:/bin' ; # where to find gnuplot, grep
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
@stat = stat($0) ; $mymodtime = $stat[9] ;

# cd to data directory
chdir ("/usr/local/etc/httpd/htdocs/beacon2/history") ;
$file = "allhistory.txt" ;
#$file = "15khistory.txt" ;
# temporary file to hold graph data; need write access to this
$ofile = "/usr/local/etc/httpd/cgi-bin/data/rd-history.dat" ;

$na = -1 ; # "no data"

# CGI variables
$method = $ENV{'REQUEST_METHOD'} ;
$query = $ENV{'QUERY_STRING'} ;
$len = $ENV{'CONTENT_LENGTH'};
$me = $ENV{'SCRIPT'} ;
$ims = $ENV{'HTTP_IF_MODIFIED_SINCE'} ;
if ($ims) {
  $ims =~ s/;.*// ; # strip length for Netscape
  $ims = get_gmtime($ims) ; # convert to Unix
}

# defaults
$style = 'lines' ; $format = 'PNG' ;

# MIME types for different output formats
$mime{'PNG'} = "image/png" ; $term{'PNG'} = "png colour" ;
$mime{'SVG'} = "image/svg+xml" ;  $term{'SVG'} = "svg" ;
$mime{'Xfig'} = "application/x-fig" ; $term{'Xfig'} = "fig colour big" ;
$mime{'PostScript'} = "application/postscript" ; $term{'PostScript'} = "postscript colour" ;

if ((($method eq 'PUT' || $method eq 'POST') && $len>0) || 
  (($method eq 'GET'|| $method eq 'HEAD')  && $query =~ /=/)) {
  if (($method eq 'PUT' || $method eq 'POST') && $len>0) {
    read(STDIN, $buffer, $len) ;
  } else {
    $buffer = $query ;
  }
  @pairs = split(/&/, $buffer);
  foreach $pair (@pairs) {
    ($name, $value) = split(/=/, $pair);
    $value =~ tr/+/ /;
    $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
    $name =~ s/</\&lt;/g ;  $name =~ s/>/\&gt;/g ;
    $value =~ s/</\&lt;/g ;  $value =~ s/>/\&gt;/g ;
    $F{$name} = $value ;
  }
}

if ($F{'style'}) { $style = $F{'style'} ; }
if ($F{'format'}) { $format = $F{'format'} ; }
$from = $F{'from'} ; $to = $F{'to'} ;
$from =~ tr/ //d ; $to =~ tr/ //d ;
$nfrom = &resolve($from) ; $nto = &resolve($to) ;
$dbg = $F{'debug'} ;
if ($F{'resolution'}) { $all = ($F{'resolution'} =~ /30/) ; } # read "allhistory" instead of every file
$pass = $F{'pass'} ;
$selLoss = $selRtt = $selJitter = '' ;
if ($pass =~ /los/) { $selLoss = ' checked' ; }
if ($pass =~ /rtt/) { $selRtt = ' checked' ; }
if ($pass =~ /jitter/) { $selJitter = ' checked' ; }

# get modification time of file (allhistory at this point)
@stat = stat($file) ; $modtime = $stat[9] ;
# also take note of the modification time of the script itself
if ($mymodtime > $modtime) { $modtime = $mymodtime ; }
$glastmod = wtime($modtime) ;
$gexpires = wtime($modtime + $expiry) ; # expire 5 minutes after modtime
if ($dbg) {
   $| = 1 ; 
  print "Content-Type: text/plain\n\n" ;
  print "Last-Modified: $glastmod\nExpires: $gexpires\n" ;
  foreach $k (keys %F) {
    print "$k $F{$k}\n" ;
  }
}

# If the file has not been modified since the IMS, return a code 304
# "not modified". This syntax works with the later Apache servers.
                                                                                                       
if ($ims && $modtime<=$ims && !$dbg) {
  print "Content-Type: $mime{$format}\nStatus: 304 Not Modified\n\n" ;
  exit ;
}


# quick check in "allhistory" to see if there's any data for selected (S,R)
#$open (IN,$file) or die ;  # searching entire file got too slow; just check a day's worth or so
open (IN,"tail -5000 $file|") or die ;
while (<IN>) {
  unless (/([\d]+),([\d]+),([\d]+),([\d:]+),([\w]+),([\w]+),([\d\.]+),([\d\.]+),([\d\-]+),([\d\-]+),([\d\-]+)/) { next ; }
  $rx = $7 ; $tx = $8 ; $loss = $9 ;
  if ($rx eq $from and $tx eq $to) { $nl = 1 ; last ; }
}
close (IN) ;

# if no data selected, display the form
unless ($from and $to and ($dbg ne '')) {
  print<<EOT;
Content-Type: text/html

<html><head>
<title>Beacon History Graph</title>
</head><body bgcolor="white">
<h2>Generate Beacon History Graph</h2>
<p>
<form action="$me">
Multicast packets from address <b>S</b> seen by address <b>R</b>:<br>
<b>S:</b> $nfrom ($from) <b>R:</b> $nto ($to); may be overridden below<p>
<b>S</b> <input type="text" name="from" value="$from" size="17">
<b>R</b> <input type="text" name="to" value="$to" size="17">
<br>
Select one or more values to plot:<br>
<b>S</b> to <b>R</b>: Loss<input type="checkbox" name="floss"$selLoss>
RTT<input type="checkbox" name="frtt"$selRtt>
Jitter<input type="checkbox" name="fjitter"$selJitter>
<br>
<b>R</b> to <b>S</b>: Loss<input type="checkbox" name="rloss">
RTT<input type="checkbox" name="rrtt">
Jitter<input type="checkbox" name="rjitter">
<br>
Debug <select name="debug">
<option>0<option>1<option>2<option>3
</select>
Graph style <select name="style">
<option>lines<option>impulses<option>points<option>boxes<option>dots
</select>
Resolution  <select name="resolution"><option>1 min<option>30 min</select>
<br>
Format <select name="format"><option>PNG<option>SVG<option>PostScript<option>Xfig</select>
<br>
Y range <input type="text" name="y1" value="*" size="8"> :
<input type="text" name="y2" value="*" size="8">
(replace "*" with number to override autoscaling)
<p>
<input type="submit" value="Plot"> (the graph may take some time to appear)
</form>
EOT
  unless ($nl) { print "<p>\n<b>Warning:</b> no archived data for above (S,R)\n<p>\n" ; }
  print<<EOT;
<p>
Notes:
<br>
A value of -1 corresponds to "NA" (no data).
<br>
Values plotted are from the  central server
<a href="http://beacon.ncsa.uiuc.edu/prevhistory.txt">previous history</a>
<br>
Formats: PNG usually displays directly, SVG and PostScript can be zoomed but require plugin, Xfig may be edited using "XFig"
on Unix/Linux.
<br>
Date/Time is from the central server (Central Time)
<hr>
<address>
Andrew Daviel
<script type="text/javascript" src="/mysig.js"></script><noscript><img src="/mysig.xbm"></noscript>
<br>
<a href="http://www.triumf.ca">TRIUMF</a>
</address>
</body></html>
EOT
  exit ;
}
$y1 = $F{'y1'} ; $y2 = $F{'y2'} ;
unless ($y1) { $y1 = '*' ; }
unless ($y2) { $y2 = '*' ; }

unless ($F{'floss'} or $F{'rloss'} or $F{'frtt'} or $F{'rrtt'} or $F{'fjitter'} or $F{'rjitter'}) {
  &error("You must select at least one variable (Loss, Jitter, etc.) to plot") ;
  exit ;
}

&clear ;
unless ($dbg) { $ofile .= $$ ; }
# create the data file for gnuplot
open (OUT,">$ofile") or die ;
print OUT "# time tfloss ftloss tfrtt ftrtt tfjitter ftjitter\n" ;
# read all history data in order
opendir (DIR,".") or die ;
foreach $file (sort bymod readdir(DIR)) {
  unless ($file =~ /^history/) { next ; } $filex = '' ;
  if ($file =~ /(history[\w\.]+)/) { $filex = $1 ; } # untaint
  if ($all) {
    $filex =  $file = "allhistory.txt" ; 
  }
  unless (-r "$file") { next ; }
  if ($dbg>1) { print "read $file\n" ; }
  $nl = 0 ;
  #open (IN,$file) or die ;
  if ($to =~ /([\d\.]+)/) { $tox = $1 ; } # untaint
  if ($from =~ /([\d\.]+)/) { $frx = $1 ; } # untaint
#  if (tainted($to)) { print "\$to $to is tainted\n" ; }
#  if (tainted($tox)) { print "\$tox $tox is tainted\n" ; }
#  if (tainted($from)) { print "\$from $from is tainted\n" ; }
#  if (tainted($frx)) { print "\$frx $frx is tainted\n" ; }
#  if (tainted($file)) { print "\$file $file is tainted\n" ; }
#  if (tainted($filex)) { print "\$filex $filex is tainted\n" ; }
#  print STDERR "grep -E \'($frx,$tox\|$tox,$frx)\' $filex|\n" ;
  open (IN,"grep -E \'($frx,$tox\|$tox,$frx)\' $filex|") or die ;
  #open (IN,"grep $frx $filex|") or die ;
  while (<IN>) {
    study ; 
    unless (/([\d]+),([\d]+),([\d]+),([\d:]+),([\w]+),([\w]+),([\d\.]+),([\d\.]+),([\d\-]+),([\d\-]+),([\d\-]+)/) { next ; }
    $y = $1 ; $m = $2 ; $d = $3 ; $hms = $4 ; # $ssrc = $5 ; $rssrc = $6 ;
    $rx = $7 ; $tx = $8 ; $loss = $9 ; $rtt = $10 ; $jitter = $11 ;
    $time = "$y-$m-$d-$hms" ;
    if ($time0 and $time ne $time0 and $start) {
      print OUT "$time $tfloss $ftloss $tfrtt $ftrtt $tfjitter $ftjitter\n" ; $nl++ ;
      &clear ;
    }
    if ($dbg>2) { print "rx \"$rx\" from \"$from\" tx \"$tx\" to \"$to\"\n" ; }
    if ($rx eq $from and $tx eq $to) {
      $start = 1 ;
      $ftloss = $loss ;
      $ffrtt = $rtt ;
      $ftjitter = $jitter ;
      if ($dbg>1) { print "$time loss $loss RTT $rtt jitter $jitter\n" ; }
    } elsif ($tx eq $from and $rx eq $to) {
      $start = 1 ;
      $tfloss = $loss ;
      $tfrtt = $rtt ;
      $tfjitter = $jitter ;
      if ($dbg>1) { print "$time reverse: loss $loss RTT $rtt jitter $jitter\n" ; }
    }
    $time0 = $time ;
  }
  if (($time0 and $time ne $time0) or $all) {
    print OUT "$time $tfloss $ftloss $tfrtt $ftrtt $tfjitter $ftjitter\n" ; $nl++ ;
  }
  if ($all) { last ; } # bail out if doing 30 min data (allhistory)
}
# add a Y label if it makes sense
if ($F{'floss'} or $F{'rloss'}) { $ylabel = "Central Loss (%)" ; $nyl++ ; }
if ($F{'frtt'} or $F{'rrtt'}) { $ylabel = "Round Trip Time (ms)" ; $nyl++ ; }
if ($F{'fjitter'} or $F{'rjitter'}) { $ylabel = "Central Jitter (ms)" ; $nyl++ ; }
if ($dbg) { 
  $ofile = "data/rd-history.dat" ; # don't show full filename in dbg
  print<<EOT;
$nl lines of data
gnuplot
set timefmt "%Y-%m-%d-%H:%M:%S"
set xdata time
set xlabel "Date/Time"
set yrange [$y1:$y2]
set title "Beacons: S = $nfrom R = $nto"
plot "$ofile" using 1:2 title 'Loss' with $style
plot "$ofile" using 1:3 title 'Reverse Loss' with $style 
plot "$ofile" using 1:4 title 'RTT' with $style
plot "$ofile" using 1:5 title 'Reverse RTT' with $style
plot "$ofile" using 1:6 title 'Jitter' with $style
plot "$ofile" using 1:7 title 'Reverse Jitter' with $style
EOT
if ($nyl == 1) { print "set ylabel \"$ylabel\"\n" ; }
  exit ;
}
unless ($nl) {
  &error ("No data matched your selection") ;
  exit ;
}
# gnuplot writes graph to stdout in selected format; prefix with MIME type
# multiple formats with no effort :-)
print<<EOT;
Content-Type: $mime{$format}
Last-Modified: $glastmod
Expires: $gexpires

EOT

open (PLOT,"|gnuplot") or die ;
print PLOT<<EOT;
set timefmt "%Y-%m-%d-%H:%M:%S"
set xdata time
set xlabel "Date/Time"
set yrange [$y1:$y2]
set title "Beacons: S = $nfrom R = $nto"
set term $term{$format}
EOT
if ($nyl == 1) { print PLOT "set ylabel \"$ylabel\"\n" ; }
$p=0 ;
# plot one or more variables
print PLOT "plot " ;
if ($F{'floss'}) { &comma ; print PLOT "\"$ofile\" using 1:2 title 'Loss' with $style" ; }
if ($F{'rloss'}) { &comma ; print PLOT "\"$ofile\" using 1:3 title 'Reverse Loss' with $style" ; }
if ($F{'frtt'}) { &comma ; print PLOT "\"$ofile\" using 1:4 title 'RTT' with $style" ; }
if ($F{'rrtt'}) { &comma ; print PLOT "\"$ofile\" using 1:5 title 'Reverse RTT' with $style" ; }
if ($F{'fjitter'}) { &comma ; print PLOT "\"$ofile\" using 1:6 title 'Jitter' with $style" ; }
if ($F{'rjitter'}) { &comma ; print PLOT "\"$ofile\" using 1:7 title 'Reverse Jitter' with $style" ; }
print PLOT "\n" ;
close(PLOT) ;
unlink ($ofile) ; # delete temporary file
exit ;

sub comma {
  if ($p) { print PLOT "," ; }
  $p++ ;
}
sub clear {
  $tfloss = $ftloss = $na ;
  $tfrtt = $ftrtt = $na ;
  $tfjitter = $ftjitter = $na ;
}
sub bymod {
# sort routine for "by modification time"
  my @stat ; my $moda ; my $modb ;
  @stat = stat($a) ;
  $moda = $stat[9] ;
  @stat = stat($b) ;
  $modb = $stat[9] ;
  return ( $moda <=> $modb) ;
}
sub error {
  print<<EOT;
Content-Type: text/html

<html><head>
<title>Beacon History Graph - Error</title>
</head><body bgcolor="white">
<h2>Error</h2>
$_[0]
</body></html>
EOT
}
sub resolve {
 # generic routine to resolve numeric ip
  my @oct = split(/\./, $_[0]);
  my $name ;
  if ( $oct[0] == 255 or $oct[1] == 255 or $oct[2] == 255 or $oct[3] == 255 
    or $oct[3] == 0  # broadcast
    or ($oct[0] == 169 && $oct[1] == 254)       # microsoft autonet
    ) {
    return $_[0] ;
  } else {
    eval {
      local $SIG{ALRM} = sub { die "alarm\n" };
      alarm 2 ;
      $name = gethostbyaddr(pack('C4',@oct),2);
      alarm 0 ;
    } ;
    if ($@) {
      die unless $@ eq "alarm\n";   # propagate unexpected errors
    }
    unless ($name) { $name = $_[0] ; }
  }
  return $name;
}

# ===========================================================================
# get_gmtime() is an extension of the datetomtime() routine found in
# htcache.pl by Gertjan van Oosten <gvoosten@isosa2.estec.esa.nl>.
#
# Description:
#	Translate a GMT date string to machine time (seconds since Epoch)
#
# Usage:
#	$mtime = &get_gmtime($date)
#
#    where $date can be any one of the following formats:
#
#	"Thu Feb  3 17:03:55 GMT 1994"        -- ctime format
#	"Wed, 09 Feb 1994 22:23:32 GMT"       -- proposed new HTTP format
#	"Tuesday, 08-Feb-94 14:15:29 GMT"     -- old rfc850 HTTP format
#	"Tuesday, 08-Feb-1994 14:15:29 GMT"   -- broken rfc850 HTTP format
#
#	"03/Feb/1994:17:03:55 -0700"   -- common logfile format
#	"09 Feb 1994 22:23:32 GMT"     -- proposed new HTTP format (no weekday)
#	"08-Feb-94 14:15:29 GMT"       -- old rfc850 HTTP format   (no weekday)
#	"08-Feb-1994 14:15:29 GMT"     -- broken rfc850 HTTP format(no weekday)
#
#	"08-Feb-94"     -- old rfc850 HTTP format    (no weekday, no time)
#	"08-Feb-1994"   -- broken rfc850 HTTP format (no weekday, no time)
#	"09 Feb 1994"   -- proposed new HTTP format  (no weekday, no time)
#	"03/Feb/1994"   -- common logfile format     (no time, no offset)

sub get_gmtime
{
    local($_) = @_;
    local($[) = 0;
    local($day, $mn, $yr, $hr, $min, $sec, $adate, $atime, $mon, $midx);
    local($offset) = 0;

    local $Mstr = 'JanFebMarAprMayJunJulAugSepOctNovDec';

    # Split date string
    local(@w) = split;

    # Remove useless weekday, if it exists
    if ($w[0] =~ /^\D/) { shift(@w); }

    if (!$w[0]) { return 0; }

    # Check which format
    if ($w[0] =~ /^\D/)   # Must be ctime (Feb  3 17:03:55 GMT 1994)
    {
        $mn    = shift(@w);
        $day   = shift(@w);
        $atime = shift(@w);
        shift(@w);
        $yr    = shift(@w);
    }
    elsif ($w[0] =~ m#/#) # Must be common logfile (03/Feb/1994:17:03:55 -0700)
    {
        ($adate, $atime) = split(/:/, $w[0], 2);
        ($day, $mn, $yr) = split(/\//, $adate);
        shift(@w);
        if ( $w[0] =~ m#^([+-])(\d\d)(\d\d)$# )
        {
            $offset = (3600 * $2) + (60 * $3);
            if ($1 eq '+') { $offset *= -1; }
        }
    }
    elsif ($w[0] =~ /-/)  # Must be rfc850 (08-Feb-94 ...)
    {
        ($day, $mn, $yr) = split(/-/, $w[0]);
        shift(@w);
        $atime = $w[0];
    }
    else                  # Must be rfc822 (09 Feb 1994 ...)
    {
        $day   = shift(@w);
        $mn    = shift(@w);
        $yr    = shift(@w);
        $atime = shift(@w);
    }
    if ($atime)
    {
        ($hr, $min, $sec) = split(/:/, $atime);
    }
    else
    {
        $hr = $min = $sec = 0;
    }

    if (!$mn || ($yr !~ /\d+/))     { return 0; }
    if (($yr > 99) && ($yr < 1970)) { return 0; }   # Epoch started in 1970

    if ($yr < 70)    { $yr += 100;  }
    if ($yr >= 1900) { $yr -= 1900; }
    if ($yr >= 138)  { return 0; }      # Epoch counter maxes out in year 2038

    # Translate month name to number
    $midx = index($Mstr, substr($mn,0,3));

    if ($midx  < 0) { return 0; }
    else            { $mon = $midx / 3; }

    # Translate to seconds since Epoch
    
    return (timegm($sec, $min, $hr, $day, $mon, $yr) + $offset);
}
sub wtime {
    local($time) = @_;
    local($[) = 0;
    local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
    local @DoW = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
    local @MoY = ('Jan','Feb','Mar','Apr','May','Jun',
        'Jul','Aug','Sep','Oct','Nov','Dec');
                                                                                                       
    ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
        gmtime($time) ;
                                                                                                       
    $year += 1900;
    sprintf("%s, %02d %s %04d %02d:%02d:%02d %s", substr($DoW[$wday],0,3),
            $mday, $MoY[$mon], $year, $hour, $min, $sec, 'GMT');
}