#########################################################################
# package Utilities.pm
# This Perl module contains utility functions, typically helpful for 
# debugging and logging

# V     Who       When         What
# ---------------------------------------------------------------------------
# 1.4.4  skendric  02-13-2009  Consult generalExcludeRoute and allowedNetworks 
#                              before bothering to run find_mask; support 
#                              new arg format in skip_networkss
# 1.4.3  skendric  07-14-2008  Reduce debugging output for debug == 8
# 1.4.2  skendric  07-03-2008  Wrap NetAddr::IP calls with eval
# 1.4.1  skendric  07-02-2008  Change skip_routers to flag_router
# 1.4.0  skendric  06-16-2008  Add find_mac, skip_networkss, skip_routers
# 1.3.0  skendric  06-09-2008  Improve normalize_mac
# 1.2.5  skendric  03-12-2007  Stylistic mods
# 1.2.4  skendric  07-03-2006  Replace Net::Syslog with Sys::Syslog
# 1.2.3  skendric  11-05-2005  Migrate by_ip from NetworkTools to Utilities
# 1.2.2  skendric  09-24-2005  Employ List::MoreUtils 'any' and 'uniq'
# 1.2.1  skendric  08-31-2005  Clean double-dash from jack fields
# 1.2.0  skendric  06-14-2005  Add csv_to_wall_jack and xls_to_wall_jack
# 1.1.6  skendric  06-13-2005  Check subroutine parameters, remove skip_nodes
# 1.1.5  skendric  02-14-2005  Replace Sys::Syslog with Net::Syslog
# 1.1.4  skendric  02-13-2005  Streamline skip_nodes
# 1.1.3  skendric  02-01-2005  Add skip_nodes
# 1.1.2  skendric  01-11-2005  Fix bug in tstamp_to_epoch
# 1.1.1  skendric  01-10-2005  Add tstamp conversion routines
# 1.1.0  skendric  01-03-2005  Adjust debugging output
# 1.0.9  skendric  09-11-2004  log_it no longer prints to terminal in 
#                              debug mode
# 1.0.8  skendric  08-28-2004  Stylistic mods, skip->skip_name
# 1.0.7  skendric  08-22-2004  Cosmetic fixes to build_list
# 1.0.6  skendric  07-14-2004  Bug fixes to wait_for_thread
# 1.0.5  skendric  07-13-2004  Enhance wait_for_thread
# 1.0.4  skendric  07-04-2004  Remove by_ip
# 1.0.3  skendric  07-02-2004  Add by_ip and wait_for_threads
# 1.0.2  skendric  06-19-2004  Cosmetic changes to trace_location
# 1.0.1  skendric  06-18-2004  Add 'bail'
# 1.0.0  skendric  06-06-2004  First version
#
#
#
# Authors:  Stuart Kendrick <sbk {insert at sign here } skendric
#                                {insert dot here} com>
#
# Source:  http://www.skendric.com/device/soma
#
# This software is available under the GNU GENERAL PUBLIC LICENSE, see
# http://www.fsf.org/licenses/gpl.html
#


package FHCRC::VDOPS::Utilities;

#### Load modules ####
use strict;
use warnings;
use threads;
use threads::shared;
use Carp qw(carp cluck croak confess);
use Data::Dumper;
use DBI;
use English;
use Exporter;
use List::MoreUtils qw(all any notall none uniq);
use Net::IPAddress qw(validaddr);
use Perl6::Say;
use Time::Local;
use Thread::Running qw(running);
use Sys::Syslog qw(:DEFAULT setlogsock);
use Switch;

use lib '/home/soma/lib';
use FHCRC::VDOPS::SomaData;

#### Set-up export stuff ####
our @ISA = qw(Exporter);
our @EXPORT = qw(
                    bail
                    build_host_list
                    epoch_to_tstamp
                    find_mask
                    flag_router
                    log_it
                    normalize_mac
                    pipe_handler
                    print_it
                    skip_networks
                    tstamp_to_epoch
                    trace_location
                    wait_for_threads
                 );

##### Only subroutines below here ####


########################################################################
# Call this routine when you've encountered an error you don't know 
# how to handle
########################################################################
sub bail {
  my $msg = shift;
  my ($line, $subroutine);

  $line = (caller(0))[2];
  $subroutine = (caller(1))[3];

  say "Fatal:  $msg";
  say "Bailed at line $line in $subroutine";
  exit;

  return 1;
} 
  
    
  

########################################################################
# Given a list of suffixes, return a reference to an array of 
# entries from the hosts table which end in those suffixes
########################################################################
sub build_host_list {
  my $aliases;                          # List of nodenames for $host
  my @aliases;                          # Array form of $aliases
  my ($key, $alias, $ip, @comment);     # Hosts table fields
  my @hosts;                            # List of possible hosts
  my @remove;                           # Duplicate removal
  my %seen;                             # Duplicate detection
  my @suffixes = @_;
  my @target;                           # @hosts filtered by @suffixes

  # Debug trace
  trace_location('begin') if $debug;

  # Sanity checking
  confess "No parameters!" unless @suffixes > 0;

  # Grab copy of hosts table
  if ($grabhosts =~ /cat/) {
    LINE:
    for my $line (split ('\n', `$grabhosts`)) {
      next LINE if $line =~ /^#/;          # Skip comment lines
      next LINE if $line =~ /::/;          # Skip IPv6 addresses
      next LINE if $line =~ /\A\s*\Z/;     # Skip blank lines
          
      ($line, @comment) = split ('#', $line);
      if ($line =~ /,/) {
        ($ip, $aliases) = split ('\s+', $line);
        @aliases = split (',', $aliases);
        push (@hosts, @aliases);
      }     
      else {
        ($ip, $aliases) = ($line =~ /(\d+\.\d+\.\d+\.\d+)\s+(.*)/);
        next LINE unless (defined $ip and defined $aliases);
        chomp $aliases;
        @aliases = split('\s+', $aliases);
        push (@hosts, @aliases);
      }
    } 
  }
      
  # Walk through hosts table, adding interesting hosts to @target
  HOST:
  for my $host (@hosts) {

    # If host doesn't contain a @suffixes, ignore
    next HOST unless any { $host =~ /$_$/ } @suffixes;

    # If host matches one of the skip patterns, ignore
    next HOST if any { $host =~ /$_/ } @skip_name;
      
    # If the host has survived this far, then we want it
    push (@target, $host);
  }

  # Remove duplicates
  @target = uniq @target;

  # Make things look pretty
  @target = sort @target;

  # Debug info
  say join($SPACE, @target) if $debug > 2;;

  # Debug trace
  trace_location('end') if $debug;

  return \@target;
}




########################################################################
# Given a time in epoch seconds, return an ISO 8601 time stamp
########################################################################
sub epoch_to_tstamp {
  my $time = shift;
  my $tstamp;
  my ($seconds, $minutes, $hours);
  my ($day_of_month, $month, $year, $wday, $yday, $isdst);

  # Debug trace
  trace_location('begin') if $debug > 2;

  # Sanity checking
  confess 'No paramters!' unless defined $time;

  # Mangle localtime's output
  ($seconds, $minutes, $hours, $day_of_month, $month, $year,
             $wday, $yday, $isdst) = localtime($time);

  $seconds = '0' . $seconds if $seconds < 10;
  $minutes = '0' . $minutes if $minutes < 10;
  $hours   = '0' . $hours   if $hours   < 10;
  $month = $month + 1;
  $year = $year + 1900;

  # Build $tstamp;
  $tstamp = $year . $DASH . $month . $DASH . $day_of_month . $SPACE;
  $tstamp .= $hours . $COLON . $minutes . $COLON . $seconds;

  # Debug trace
  trace_location('end') if $debug > 2;

  return $tstamp;
}




########################################################################
# Given an IP address, consult %routeTable and return the mask of the 
# associated network
########################################################################
sub find_mask {
  my $addr_obj;            # NetAddr::IP object created from $ip
  my $answer;
  my $home;                # Route inside which $ip lives
  my $ip = shift;

  # Debug trace
  trace_location('begin') if $debug == 10;

  # Sanity checking
  confess 'No paramters!'       unless defined $ip;
  confess "Invalid address $ip" unless validaddr($ip);

  # Create NetAddr::IP object
  eval { $addr_obj = NetAddr::IP->new($ip) };
  if ($@ or not defined $addr_obj) {
    log_it("Bad addr $ip: $@");
    goto END;
  }

  # Walk route table
  ROUTE:
  for my $route (keys %routeTable) {
    my ($mask, $route_obj);
    $mask = $routeTable{$route};

    # Create NetAddr::IP object
    eval { $route_obj = NetAddr::IP->new($route, $mask) };
    if ($@ or not defined $route_obj) {
      log_it("Bad route $route / $mask: $@");
      next ROUTE;
    }

    # If this address lives inside this route, say yes
    if ($route_obj->contains($addr_obj)) {
      $answer = $mask;
      $home = $route;
      last ROUTE;
    }

  }

  # Talk about what we see
  switch ($answer) {
    case 0 {
      log_it("Could not find route for $ip in routeTable");
    }
    case 1 {
      say "$ip lives inside $home/$answer" if $debug == 10;
    }
  }

  END:

  # Debug trace
  trace_location('end') if $debug == 10;

  return $answer;
}




########################################################################
# Given a NetAddr::IP object, guess whether this address belongs to a 
# router, returning a 1 if yes and a 0 if no.  In our environment, router 
# interfaces are numbered 1, 2, or 3
########################################################################
sub flag_router {
  my $addr = shift;
  my $flag = 0;
  my $network;            # NetAddr::IP object describing the network 
                          # containing $obj
  my $router;             # NetAddr::IP object which cycles through the 
                          # possible router nodes (1, 2, and 3)
  
  # Debug trace
  trace_location('begin') if $debug == 10;

  # Sanity checking
  confess 'No parameters' unless defined $addr;
  confess "$addr is not an NetAddr::IP object" unless ref $addr eq 'NetAddr::IP';

  # Find network
  $network = $addr->network();

  # Find first router address (x.y.z.1)
  $router = $network->first();

  # Cycle through the router nodes, setting flag if we find one identical 
  # to 1, 2, or 3
  ROUTER:
  for (my $i = 1; $i < 4; $i++) {
    if ($router eq $addr) {
      $flag = 1;
      last ROUTER;
    }
    $router++
  }
    
  # Debug info
  if ($flag == 1 and $debug == 8) {
    my $got_one = $addr->addr();
    print_it("$got_one is a router\n")
  }

  # Debug trace
  trace_location('end') if $debug == 10;

  return $flag;
}




########################################################################
# Send messages to syslog
########################################################################
sub log_it{
  my $ident;
  my $msg = shift;
  my $username = getpwuid($UID);

  # Debug trace
  trace_location('begin') if $debug == 10;

  # Check for content
  $msg = 'undefined' if (not defined $msg or $msg eq $EMPTY_STR);

  # Assign Sys::Syslog variables
  $Sys::Syslog::host = $syslog_host;
  $Sys::Syslog::host = $Sys::Syslog::host;  # Avoid warning

  # Construct ident
  #$ident = $username . '_is_running_' . $PROGRAM_NAME;
  $ident = $username . $SPACE . $PROGRAM_NAME;

  # Strip new lines from message
  $msg =~ s/\n//g;

  # Send it to syslog
  setlogsock($syslog_socket) or carp "Cannot setlogsock to $syslog_socket: $!";
  openlog($ident, 'nofatal,ndelay,pid', $syslog_facility);
  syslog($syslog_priority, $msg);
  closelog();

  # Debug trace
  trace_location('end') if $debug == 10;

  return 1;
}




########################################################################
# Given a MAC address, normalize it into a twelve byte, colon-delimited, 
# lower-case format.  (cribbed from Sean Harding's IPToPort.pm).
# Also, check to see if it belongs to @invalidMAC; if it does, return 
# undef; otherwise, returned the normalized form
########################################################################
sub normalize_mac {
  my $inMAC = shift;
  my $outMAC;
  $outMAC = $inMAC;
  my @invalidMAC = qw/00:00:00:00:00:00 ff:ff:ff:ff:ff:ff/;

  # Debug trace
  trace_location('begin') if $debug == 10;

  # Sanity checking
  confess 'No parameters!' unless defined $inMAC;

  # Strip and replace
  $outMAC =~ s/^0x//;     # Strip leading hex symbol
  $outMAC =~ s/\"//g;     # Strip quotes
  $outMAC =~ s/^\s+//g;   # Strip leading spaces
  $outMAC =~ s/\s+$//g;   # Strip trailing spaces
  $outMAC =~ tr/A-F/a-f/; # Convert letters to lower-case
  $outMAC =~ s/-/:/g;     # Replace dashes with colons
  $outMAC =~ s/\s/:/g;    # Replace spaces with colons

  # Prepend 0 to any single value
  $outMAC =~ s/^([0-9a-f]):/0$1:/i;   # Handle the first field
  $outMAC =~ s/:([0-9a-f]):/:0$1:/ig; # Handle the 2nd - 5th fields
  $outMAC =~ s/:([0-9a-f]):/:0$1:/i;  # Why didn't the 'g' work?
  $outMAC =~ s/:([0-9a-f]):/:0$1:/i;  # Fine, we'll just repeat
  $outMAC =~ s/:([0-9a-f]):/:0$1:/i;  # Handle the 5th field
  $outMAC =~ s/:([0-9a-f])$/:0$1/i;   # Handle the last field

  # If the twelve characters aren't divided up by five colons, fix it
  my $num_colons = lc($outMAC) =~ tr/$COLON//;
  unless ($num_colons == 5) {
    ($outMAC = $outMAC) =~ s/://g;    # Strip existing colons
    $outMAC = join $COLON, unpack 'a2a2a2a2a2a2', $outMAC;  # Insert 5 colons
  }

  # Double-check
  if ($outMAC =~ /^[0-9a-f]{1,2}:[0-9a-f]{1,2}:[0-9a-f]{1,2}:[0-9a-f]{1,2}:[0-9a-f]{1,2}:[0-9a-f]{1,2}$/i ) {
    undef $outMAC if any { $outMAC eq $_ } @invalidMAC;
  }
  else {
    undef $outMAC;
  }

  # Debug info
  if ($debug == 8) {
    if (defined $outMAC) {
      say "  in = $inMAC, out = $outMAC";
    }
    else {
      say "  in = $inMAC, out = undef";
    }
  }

  # Debug trace
  trace_location('end') if $debug == 10;

  return $outMAC;
}




########################################################################
# Handle SIGPIPE
########################################################################
sub pipe_handler {
  my $sig = shift @_;
  say " Caught SIGPIPE: $sig $1";
  exit(1);
}




########################################################################
# Print line to STDOUT or to Syslog
########################################################################
sub print_it {
  my $line = shift;

  if ($job eq 'interactive') {
    print $line;
  }
  else {
    log_it($line);
  }

  return 1;
}




#######################################################################
# Given a NetAddr::IP object, along with a reference to a hash of masks
# keyed by route, figure out whether or not the object lives within
# the routes stored in the hash.  Return 1 if it does, 0 otherwise.
########################################################################
sub skip_networks {
  my $answer = 0;            # Boolean answer
  my $addr = shift;          # NetAddr::IP object of interest
  my $route_ref = shift;     # Reference to hash of masks keyed by route

  # Debug trace
  trace_location('begin') if $debug == 10;

  # Sanity check
  confess 'Must define addr'             unless defined $addr;
  confess 'Must define route_ref'        unless defined $route_ref;
  confess 'First argument must be a NetAdddr:IP object' unless ref $addr eq 'NetAddr::IP';
  confess 'Second argument must be a hash' unless ref $route_ref eq 'HASH';

  # Walk hash
  ROUTE:
  for my $route (keys %$route_ref) {
    my ($mask, $route_obj);
    
    # Assign mask
    $mask = $route_ref->{$route};

    # Create NetAddr::IP object
    eval { $route_obj = NetAddr::IP->new($route, $mask) };
    if ($@ or not defined $route_obj) {
      log_it("Bad route $route / $mask: $@");
      next ROUTE;
    }

    # If the incoming address lives within this route, say yes
    if ($addr->within($route_obj)) {
      $answer = 1;
      last ROUTE;
    }
  }

  # Debug trace
  trace_location('end') if $debug == 10;

  return $answer;
}




########################################################################
# Given a time in ISO 8601, return a time in local epoch seconds
########################################################################
sub tstamp_to_epoch {
  my $epoch;
  my $tstamp = shift;
  my ($second, $minute, $hour);
  my ($day, $month, $year);

  # Debug trace
  trace_location('begin') if $debug > 2;

  # Sanity checking
  confess "No parameters!" unless defined $tstamp;

  # Pull apart timeStamp
  ($year, $month, $day, $hour, $minute, $second) = 
      ($tstamp =~ /(\d\d\d\d)-(\d\d)-(\d\d) (\d\d):(\d\d):(\d\d)/);

  # timelocal wants months to fall within 0-11 rather than the 1-12 
  # which we use in Soma
  $month--;

  # Convert to epoch seconds or barf
  if (defined $day    and defined $month  and defined $year and
      defined $second and defined $minute and defined $hour) {
    $epoch = timelocal($second, $minute, $hour, $day, $month, $year);
  }
  else {
    print_it("tstamp in wrong format:  $tstamp");
  }

  # Debug trace
  trace_location('end') if $debug > 2;

  return $epoch;
}




########################################################################
# Show the programmer where we are
########################################################################
sub trace_location {
  my $location = shift;
  my ($subroutine) = (caller (1))[3];

  if ($location eq 'begin') {
    say "Entering $subroutine";
  }
  elsif ($location eq 'end') {
    say "Leaving $subroutine";
  }

  return 1;
}




#######################################################################
# Given a reference to an array of thread objects, and an option 
# 'factor', wait a while for them to exit.  I want to give these threads 
# a chance of completing ... but I don't want to wait forever.  I figure 
# that if the number of running threads is decrementing steadily, that I'm
# willing to keep waiting; otherwise, I want to give up and continue.
# Use the number of currently running threads as a gauge for how long
# to sleep before checking again ... the larger the number, the longer
# we'll go to sleep.  Use the 'factor' variable to further modify how 
# long we sleep (the larger the 'factor', the longer we sleep ... I 
# increase 'factor' for long-running processes, like nmap and nessus).
########################################################################
sub wait_for_threads {
  my $caller;                    # Name of subroutine which called us
  my $me;                        # Name of this subroutine
  my @newRunning;                # List of running thread objects
  my @oldRunning;                # List of running thread objects
  my $pause;                     # The number of seconds we sleep initially
  my $ref_threads = shift;       # List of spawned thread objects
  my $factor = shift;            # 'Decay' factor

  # Debug trace
  trace_location('begin') if $debug;

  # Sanity checking
  confess 'No parameters!'           unless defined $ref_threads;
  confess 'Wrong type for parameter' unless ref $ref_threads eq 'ARRAY';

  # Define variables
  ($caller) = (caller (1))[3];
  $factor = 3 unless defined $factor;
  ($me) = (caller (0))[3];

  # Identify the number of running threads.
  @oldRunning = threads->running( @$ref_threads );
  $pause = $thrWait + $factor * @oldRunning; 

  # If we have outstanding threads, wait a while
  if (@oldRunning > 0) {
    if ($debug > 1) {
      say scalar @oldRunning, " threads currently running, sleeping for $pause seconds";
    }
    sleep $pause;
    @newRunning = threads->running( @$ref_threads );
  }

  # If all threads are done, then $oldRunning will contain zero entries, and
  # we won't enter the loop, because 'new' will equal 'old', and the loop
  # test will fail.  If some threads are still running, then $oldRunning 
  # and $newRunning will be non-zero ... if they are equal, then assume 
  # that they have encountered a problem, they are hung, and quit.
  # If $newRunning < $oldRunning, then we are making progress.  Enter 
  # the loop and stay there as long as $newRunning < $oldRunning, i.e. as 
  # long as the number of running threads is decrementing.
  THREAD:
  while (@newRunning < @oldRunning) {

    # Capture 'running'
    @oldRunning = threads->running( @$ref_threads );

    # Sleep a little
    sleep ($thrWait + $factor * @oldRunning);

    # Capture 'running'
    @newRunning = threads->running( @$ref_threads );
    say scalar @newRunning, " threads currently running" if $debug > 1;

    # If the latest value of 'running' is zero, then we're done:  bail.
    last THREAD if @newRunning == 0;
  
  }

  # If we are leaving with threads still running, record that fact
  @newRunning = threads->running( @$ref_threads );
  if (@newRunning > 0) {
    my $string = "FYI:  I am returning to $caller even though " . scalar @newRunning . " threads have not yet finished.\n";
    print_it("$string");
  }

  # Debug trace
  trace_location('end') if $debug; 
  
  return 1;
} 
  

    

########################################################################
# Remove elements from @target
########################################################################
sub yank_target {
  my $ref_target = shift;
  my $ref_remove = shift;
  my $numTargets = @$ref_target - 1;
      
  # Debug trace
  trace_location('begin') if $debug;
 
  # Sanity checking
  confess 'Not enough parameters!' unless defined $ref_target and defined $ref_remove;
  confess 'Wrong type for first parameter' unless ref $ref_target eq 'ARRAY';
  confess 'Wrong type for second parameter' unless ref $ref_remove eq 'ARRAY';

  # Remove entries which failed checks
  for (my $i = $numTargets; $i >= 0; $i--) {
    if (defined @$ref_remove[$i]) {
      splice @$ref_target, $i, 1;
    } 
  }

  # Reset @remove
  undef @$ref_remove;

  # Debug trace
  trace_location('end') if $debug;

  return 1;
}