#!/usr/bin/perl

# Pragma
use strict;
use warnings;
# Libraries
use File::Path qw( remove_tree );
use File::Temp qw( tempdir );
use Getopt::Long;
use Time::HiRes qw( gettimeofday tv_interval );

BEGIN
{
  print "======================= Greenstone Import + I/O Metrics ======================\n\n";
  if (!defined $ENV{'GSDLHOME'})
  {
    print "Error! GSDLHOME not set\n\n";
    exit;
  }
}

# 1. Parse and sanitize arguments - the listing of syscalls whose duration we
# accumulate as IO time. Unless otherwise noted, these are taken from what
# strace_analyzer.pl would use
print " * Initializing... Done\n";
our $strace_flags = '-f -q -s 256 -T -ttt';
our $io_function_list = {
                         'access'=>1,
                         'chmod'=>1,
                         'close'=>1,
                         'creat'=>1,
                         'fclose'=>1,
                         'fcntl'=>1,
                         'fgetpos'=>1,
                         'flock'=>1,
                         'fseek'=>1,
                         'fsetpos'=>1,
                         'fstat'=>1,
                         'fsync'=>1,
                         'ftell'=>1,
                         'getdents'=>1,
                         #'ioctl'=>1, # John added
                         'llseek'=>1,
                         'lockf'=>1,
                         'lseek'=>1,
                         'lseek64'=>1,
                         'mkdir'=>1,
                         'open'=>1,
                         'read'=>1,
                         'readdir'=>1,
                         'rename'=>1,
                         'rewind'=>1,
                         'rewinddir'=>1,
                         'scandir'=>1,
                         'stat'=>1,
                         'stat64'=>1,
                         'telldir'=>1,
                         'unlink'=>1,
                         'write'=>1
                        };
my $start_time = [gettimeofday()];
my $collection = '';
my $debug = 0;
my $flush_delay = 3;

GetOptions ('collection=s' => \$collection,
            'debug' => \$debug,
            'flushdelay=i' => \$flush_delay)
or &printUsage('Invalid or missing argument');

if (!defined $collection || $collection eq '')
{
  &printUsage('Missing collection name');
}
my $collection_path = $ENV{'GSDLHOME'} . '/collect/' . $collection;
if (!-d $collection_path)
{
  &printUsage('Collection not found: ' . $collection_path);
}
print '   - Greenstone:  ' . $ENV{'GSDLHOME'} . "\n";
print '   - Collection:  ' . $collection . "\n";
print '   - Flush Delay: ' . $flush_delay . "\n";
print '   - Debug?       ' . ($debug ? 'Yes' : 'No') . "\n";
print "\n";

# 2. Run dummy import command (empty import directory) within trace to
# determine baseline
&clearArchives();
&flushDiskCache($flush_delay);
print " * Running baseline collection import... ";
my $dummy_dir = tempdir( CLEANUP => 1);
my $command1 = 'strace ' . $strace_flags . ' import.pl -removeold -importdir "' . $dummy_dir .'" "' . $collection . '" 2>&1';
my $debug_path1 = '';
if ($debug)
{
  $debug_path1 = $collection_path . '/debug-baseline.tsv';
}
my ($baseline_duration, $baseline_io, $baseline_misc) = &parseStrace($command1, $collection_path, $debug_path1);
print "Done\n";
print '   - Duration:      ' . sprintf('%0.6f', $baseline_duration) . " seconds\n";
print '   - SysCall Time:  ' . sprintf('%0.6f', $baseline_io + $baseline_misc) . " seconds\n";
print '   - SysCall Prct:  ' . sprintf('%d', (($baseline_io + $baseline_misc) / $baseline_duration) * 100) . "%\n";
print '   - I/O Time:      ' . sprintf('%0.6f', $baseline_io) . " seconds\n";
print '   - I/O Percent:   ' . sprintf('%d', ($baseline_io / $baseline_duration) * 100) . "%\n";
if ($debug)
{
  print "   - See 'debug-baseline.tsv' for raw data\n";
}
print "\n";

# 3. Run normal import command within strace reading output line by line
&clearArchives();
&flushDiskCache($flush_delay);
print " * Running import and tracking I/O metrics... ";
my $command2 = 'strace ' . $strace_flags . ' import.pl -removeold "' . $collection . '" 2>&1';
my $debug_path2 = '';
if ($debug)
{
  $debug_path2 = $collection_path . '/debug-import.tsv';
}
my ($duration_import, $duration_io, $duration_misc, $import_complete, $docs_found, $docs_processed) = &parseStrace($command2, $collection_path, $debug_path2);
print "Done\n";
print '   - Import?        ' . ( $import_complete ? 'Completed' : 'Failed') . "\n";
print '   - Found:         ' . $docs_found . ' document' . (($docs_processed > 1) ? 's' : '') . "\n";
print '   - Processed:     ' . $docs_processed . ' document' . (($docs_processed > 1) ? 's' : '') . "\n";
print '   - Duration:      ' . sprintf('%0.6f', $duration_import) . " seconds\n";
print '   - SysCall Time:  ' . sprintf('%0.6f', $duration_io + $duration_misc) . " seconds\n";
print '   - SysCall Prct:  ' . sprintf('%d', (($duration_io + $duration_misc) / $duration_import) * 100) . "%\n";
print '   - I/O Duration:  ' . sprintf('%0.6f', $duration_io) . " seconds\n";
print '   - I/O Percent:   ' . sprintf('%d', ($duration_io / $duration_import) * 100) . "%\n";
print "   - See 'import.log' for Greenstone Import details\n";
print "   - See 'strace.out' for STrace details\n";
if ($debug)
{
  print "   - See 'debug-import.tsv' for raw data\n";
}
print "\n";

# 4. Results
print &makeHeader('Import Results', 78) . "\n\n";
print " Import Duration:  " . sprintf('%0.6f', ($duration_import - $baseline_duration)) . " seconds\n";
print " I/O Duration:     " . sprintf('%0.6f', ($duration_io - $baseline_io)) . " seconds\n";
print " I/O Percentage:   " . sprintf('%d', ((($duration_io - $baseline_io)/($duration_import - $baseline_duration)) * 100)) . "%\n";
print "\n";

# Complete!
my $end_time = [gettimeofday()];
my $duration = tv_interval($start_time, $end_time);
print &makeHeader(sprintf('Complete in %0.2f seconds', $duration), 78) . "\n\n";

exit;


## @function
#
sub makeHeader
{
  my ($msg, $length) = @_;
  if (length($msg) % 2 == 1)
  {
    $msg = ' ' . $msg . '  ';
  }
  else
  {
    $msg = ' ' . $msg . ' ';
  }
  while (length($msg) < $length)
  {
    $msg = '=' . $msg . '=';
  }
  return $msg;
}
## makeHeader() ##


## @function
#
sub clearArchives
{
  # 2. Remove any existing archives directory, so it doesn't get factored in the
  # IO costs
  my $archives_dir = $collection_path . '/archives';
  if (-d $archives_dir)
  {
    print " * Deleting existing archives directory... ";
    remove_tree($archives_dir);
    print "Done\n";
  }
}
## clearArchives()


## @function
#
sub flushDiskCache
{
  my ($flush_delay) = @_;
  # The Premise: use sudoedit and other black magic to clear out the memory-
  # based disk cache (which is done by writing the number 3 to a certain
  # system file)
  &printFlush(" * Synching file system... ");
  `sync`;
  print "Done\n";
  &printFlush(" * Dropping memory disk cache... ");
  # - save our current default editor
  my $current_editor = $ENV{'EDITOR'};
  # - replace default editor with a script that simply clobbers the contents
  #   of any file it's handed with the number "3"
  $ENV{'EDITOR'} = 'reset_memcache_editor.sh';
  # - we now call sudoedit on the system file. How sudoedit works is that it
  #   starts by making a temp copy of the system file with appropriate
  #   permissions allowing the user to edit. It then passes the path to the
  #   temp file to the default editor - typically this would be an interactive
  #   editor like 'vi'. However, we've just replaced the editor with a custom
  #   script that just writes '3' as the content of the tmp file. Finally, when
  #   the editor exits, sudoedit copies the tmp file over the top of the system
  #   file, restoring appropriate root-level permissions
  `sudoedit /proc/sys/vm/drop_caches`;
  # - restore the default editor, just in case something in Greenstone
  #   depends on this being a reasonably value
  $ENV{'EDITOR'} = $current_editor;
  print "Done\n";
  # - short break to give OS time to actually notice the drop_caches command
  &printFlush(" * Waiting for drop_caches to complete... ");
  while ($flush_delay > 0)
  {
    &printFlush($flush_delay . ' ');
    sleep(1);
    $flush_delay--;
  }
  print "Done\n\n";
}
## flushDiskCache()


## @function parseStrace
#
sub parseStrace
{
  my ($command, $logs_path, $debug_path) = @_;
  my $start_timestamp = 0;
  my $end_timestamp = 0;
  my $io_duration = 0;
  my $misc_duration = 0;
  my $import_complete = 0;
  my $documents_found = 0;
  my $documents_processed = 0;
  # hash from PIDs to array (FIFO stack) of syscalls and arguments
  my $interrupted_stacks = {};

  # open the logs if we have been given somewhere to log too
  my $logging_enabled = 0;
  if ($logs_path ne '')
  {
    my $strace_path = $logs_path . '/strace.out';
    open(STRACEOUT, '>:utf8', $strace_path) or die("Error! Failed to open file for writing: " . $strace_path);
    my $gslog_path = $logs_path . '/import.log';
    open(GSLOGOUT, '>:utf8', $gslog_path) or die("Error! Failed to open file for writing: " . $gslog_path);
    $logging_enabled = 1;
  }

  # debug mode means writing a whole bunch of information to a CSV
  if ($debug_path)
  {
    open(TSVOUT, '>:utf8', $debug_path) or die('Error! Failed to open file for writing: '  . $logs_path . '/' . $debug);
    print TSVOUT "TIMESTAMP\tPID\tSYSCALL\tELAPSED\tTOTALIO\tTOTALMISC\tARGS\tRESULT\n";
  }

  if (open(GSI, $command . '|'))
  {
    my $pid = 0;
    my $line = <GSI>;
    while ($line)
    {
      my $next_line = <GSI>;
      if ($logging_enabled)
      {
        print STRACEOUT $line;
      }
      # we may have a line that unfortunately includes newlines in its arguments list
      # - watch out for unfinished syscalls that will be resumed later
      # - oh! and signals, cause they are way different anyhow
      while ($line !~ /<unfinished \.\.\.>/ && $line !~ /SIG/ && $line =~ /\(/ && $line !~ /\)\s+=/)
      {
        $line .= ' ' . $next_line;
        if ($next_line = <GSI>)
        {
        }
        else
        {
          print "Error! Failed to find complete arguments list: " . $line . "\n";
          exit;
        }
      }
      # detect and remove any PID information to make the rest of parsing easier
      if ($line =~ /^\[pid\s+(\d+)\]\s+(.*)$/s)
      {
        my $new_pid = $1;
        $line = $2;
        if ($new_pid != $pid)
        {
          $pid = $new_pid;
        }
      }
      # detect resume lines, and rewrite so they look like other lines
      if ($line =~ /^(\d+\.\d+)\s+<\.\.\.\s+([a-z0-9_]+)\s+resumed>\s+(.*)\)\s+=\s+(.+)\s+<(\d+\.\d+)>$/s)
      {
        my $timestamp = $1;
        my $prev_syscall = '';
        my $syscall = $2;
        my $args_prefix = '';
        my $args_suffix = $3;
        my $result = $4;
        my $duration = $5;
        if ($syscall eq 'write' && $args_prefix =~ /^[12],/)
        {
          chomp($line);
          print "\n\nResuming write pid:$pid line:|" . $line . "|\n";
          # pop the last interrupted syscall off the stack for this pid
          if (!defined $interrupted_stacks->{$pid} || scalar(@{$interrupted_stacks->{$pid}}) == 0)
          {
            print "Error! Resume when stack is empty: " . $pid . "\n";
            exit;
          }
          ($prev_syscall, $args_prefix) = @{pop(@{$interrupted_stacks->{$pid}})};
          if ($syscall ne $prev_syscall)
          {
            print "Error! Resume syscall does not match unfinished syscall: " . $syscall . " != " . $prev_syscall . "\n";
            exit;
          }
        }

        # Time for a hack - duration is highly dubious for suspended
        # syscalls. It typically includes the total walltime spent doing
        # anything between when the 'unfinished' and the 'resumed'... time that
        # is already accounted for in other parsed syscalls.  What I'll do is
        # limit the resumed calls duration to, at most, the time difference
        # between this syscall and the next. This is highly inaccurate, of
        # course, as it includes time spent in userspace but is significantly
        # better than a elasped duration several times longer than the syscall
        # actually took.
        if ($next_line =~ /^.*?(\d+\.\d+)/)
        {
          my $next_timestamp = $1;
          my $timestamp_duration = $next_timestamp - $timestamp;
          if ($duration > $timestamp_duration)
          {
            #rint "[resume: elapsed longer than duration... fudging] ";
            $duration = $timestamp_duration;
          }
        }

        $line = $timestamp . ' ' . $syscall . '(' . $args_prefix . ' ' . $args_suffix . ') = ' . $result . ' <' . sprintf('%0.6f', $duration) . '>';
      }

      # SPECIAL CASES
      # - unfinished syscalls... the only ones we care about are writes to standard out or error as these are echoed to the shell.  Add them to the appropriate stack waiting for the 'resume' rewrite above
      if ($line =~ /^(\d+\.\d+)\s+([a-z0-9_]+)\((.*?)\s+<unfinished \.\.\.>$/)
      {
        my $timestamp = $1;
        my $syscall = $2;
        my $args_prefix = $3;
        if ($syscall eq 'write' && $args_prefix =~ /^[12],/)
        {
          print "\n\nPending write pid:$pid line:|" . $line . "|\n";
          if (!defined $interrupted_stacks->{$pid})
          {
            $interrupted_stacks->{$pid} = [];
          }
          push(@{$interrupted_stacks->{$pid}}, [$syscall, $args_prefix]);
        }
      }
      # - processes announce detachments and resumptions - maybe this explains
      # why wait4's keep chaning (-q should shut these up)
      elsif ($line =~ /^Process (\d+) (detached|resumed)/)
      {
        my $local_pid = $1;
        my $action = $2;
      }
      # - exit_group never has a duration
      elsif ($line =~ /^(\d+\.\d+)\s+exit_group\((\d+)\)\s+=\s+\?$/)
      {
        my $timestamp = $1;
        my $exit_value = $2;
        $end_timestamp = $timestamp;
        if ($debug)
        {
          print TSVOUT sprintf("%0.6f", ($timestamp - $start_timestamp)) . "\t";
          print TSVOUT $pid . "\t";
          print TSVOUT "exit_group\t";
          print TSVOUT "0.000000\t";
          print TSVOUT sprintf("%0.6f", $misc_duration) . "\t";
          print TSVOUT sprintf("%0.6f", $io_duration) . "\t";
          print TSVOUT $exit_value . "\t";
          print TSVOUT "?\n";
        }
      }
      # - signals
      elsif ($line =~ /^(\d+\.\d+)\s+---\s+([A-Z]+)\s+\((.*)\)\s+\@\s+0\s+\(0\)\s+---$/)
      {
        my $timestamp = $1;
        my $signal = $2;
        my $message = $3;
        $end_timestamp = $timestamp;
      }
      # NORMAL CASE
      elsif ($line =~ /^(\d+\.\d+)\s+([a-z0-9_]+)\((.*)\)\s+=\s+(.+)\s+<(\d+\.\d+)>$/s)
      {
        my $timestamp = $1;
        my $syscall = $2;
        my $args = $3;
        my $result = $4;
        my $duration = $5;
        if ($start_timestamp == 0)
        {
          $start_timestamp = $timestamp;
        }
        $end_timestamp = $timestamp;
        if (defined $io_function_list->{$syscall})
        {
          $io_duration += $duration;
        }
        else
        {
          $misc_duration += $duration;
          ##print "[$syscall]";
        }
        if ($syscall eq 'write' && $args =~ /[12],\s+"(.*)"/s)
        {
          my $payload = $1;
          $payload =~ s/\\n/\n/g;
          # parse up some collection import statistics
          if ($payload =~ /Import complete/)
          {
            $import_complete = 1;
          }
          elsif ($payload =~ /^\* (\d+) documents were considered/)
          {
            $documents_found = $1;
          }
          elsif ($payload =~ /^\* (\d+) were processed/)
          {
            $documents_processed = $1;
          }
          # finally, write these lines out to log if a path has been provided
          if ($logging_enabled)
          {
            print GSLOGOUT $payload;
          }
        }
        if ($debug)
        {
          $args =~ s/\r?\n//g;
          print TSVOUT sprintf("%0.6f", ($timestamp - $start_timestamp)) . "\t";
          print TSVOUT $pid . "\t";
          print TSVOUT $syscall . "\t";
          print TSVOUT sprintf("%0.6f", $duration) . "\t";
          print TSVOUT sprintf("%0.6f", $misc_duration) . "\t";
          print TSVOUT sprintf("%0.6f", $io_duration) . "\t";
          print TSVOUT $args . "\t";
          print TSVOUT $result . "\n";
        }
      }
      else
      {
        chomp($line);
        print "\n\nUnparsed: |" . $line . "|\n\n";
      }
      # Move on to the next line... (may be undef)
      $line = $next_line;
    }
  }
  else
  {
    print "Error! Failed to open import process for reading: " . $command . "\n";
  }
  if ($logging_enabled)
  {
    close(STRACEOUT);
    close(GSLOGOUT);
  }
  if ($debug_path)
  {
    close(TSVOUT);
  }
  my $cmd_duration = $end_timestamp - $start_timestamp;
  return ($cmd_duration, $io_duration, $misc_duration, $import_complete, $documents_found, $documents_processed);
}
# parseStrace()


sub printFlush
{
  my ($msg) = @_;
  $| = 1;
  print $msg;
  $| = 0;
}


sub printUsage
{
  my ($msg) = @_;
  if (defined $msg)
  {
    print 'Error! ' . $msg . "\n";
  }
  print "Usage: import_with_io_metric.pl -collection <collection name> [-debug]\n\n";
  exit;
}

1;