source: gs2-extensions/parallel-building/trunk/src/opt/Perseus/perseus.pl@ 29649

#!/usr/bin/perl

# Pragma
use strict;
use warnings;
$|++; # Unbuffer STDOUT

# Perl Built-in Modules
use Getopt::Long;
use IO::Socket::INET;
use LWP::Simple;
use Pod::Usage;

my $txt_buffer = '';

my $start_time = time();
&printBuffer("[" . localtime($start_time) . "]\n");
&printBuffer("===== Persus =====\n");
&printBuffer("To slay a Medusa you need an appropriately shiney shield - this is\n";
&printBuffer("that shield.\n");
&printBuffer("\n");

# 1. Configuration
my $debug = 0;
my $help = 0;
my $kill_delay = 5;
my $listen_time = 60;
my $man = 0;
my $search_path = '';
my $search_port = 39875;
my $search_url = 'http://www.cms.waikato.ac.nz/~jmt12/perseus.txt';
my $log_path = '/tmp/perseus.log';
GetOptions ('debug'         => \$debug,
            'kill_delay=i'  => \$kill_delay,
            'listen_port=i' => \$search_port,
            'listen_time=i' => \$listen_time,
            'path=s'        => \$search_path,
            'url=s'         => \$search_url,
            'log=s'         => \$log_path,
            'help|?'        => \$help,
            man             => \$man
           )
or pod2usage(2);
if ($help)
{
  pod2usage(1);
}
if ($man)
{
 pod2usage(-exitval => 0, -verbose => 2);
}
&printBuffer(" * Configuration\n");
&printBuffer("   - Debug? " . ($debug ? "Yes" : "No") . "\n");
&printBuffer("   - Search path: " . $search_path . "\n");
&printBuffer("   - Search URL: " . $search_url . "\n");
&printBuffer("   - Search port: " . $search_port . "\n");
&printBuffer("   - Listen time: " . $listen_time . " seconds\n");
&printBuffer("   - Delay before KILL: " . $kill_delay . " seconds\n");
&printBuffer("   - Log path: " . $log_path . "\n");

# 2. Search
&printBuffer(" * Looking for Instructions\n");
my $instructions = [];
&printBuffer("   - Listen on port... ");
if ($search_port > 0)
{
  if (&searchPort())
  {
    &printBuffer("Contacted\n");
  }
  else
  {
    &printBuffer("No contact\n");
  }
}
else
{
  &printBuffer("Skipped\n");
}
&printBuffer("   - Search for internet page... ");
if (!scalar(@{$instructions}))
{
  if (&searchURL())
  {
    &printBuffer("Found\n");
  }
  else
  {
    &printBuffer("Not found\n");
  }
}
else
{
  &printBuffer("Skipped\n");
}
&printBuffer("   - Search for sentinel file... ");
if (defined $search_path && $search_path ne '' && !scalar(@{$instructions}))
{
  if (&searchPath())
  {
    &printBuffer("Found\n");
  }
  else
  {
    &printBuffer("Not found\n");
  }
}
else
{
  &printBuffer("Skipped\n");
}

# 3. Action
if (scalar(@{$instructions}))
{
  &printBuffer(" * Processing Instructions\n");
  my @instructions2;
  # - terms and kills first
  my $instruction_ptr = shift(@{$instructions});
  while (defined $instruction_ptr)
  {
    my @instruction = @{$instruction_ptr};
    &printDebug("[instruction=" . $instruction[0] . ':' . $instruction[1] . "]");
    if ($instruction[0] eq 'pid')
    {
      &commandTerminate($instruction[1]);
    }
    else
    {
      push(@instructions2, $instruction_ptr);
    }
    $instruction_ptr = shift(@{$instructions});
  }
  # - then slays
  $instruction_ptr = shift(@instructions2);
  while (defined $instruction_ptr)
  {
    my @instruction = @{$instruction_ptr};
    if ($instruction[0] eq 'user')
    {
      &commandSlay($instruction[1]);
    }
    else
    {
      push(@{$instructions}, $instruction_ptr);
    }
    $instruction_ptr = shift(@instructions2);
  }
  # - then commands (reboot)
  $instruction_ptr = shift(@{$instructions});
  while (defined $instruction_ptr)
  {
    my @instruction = @{$instruction_ptr};
    if ($instruction[0] eq 'cmd' && $instruction[1] eq 'reboot')
    {
      &commandReboot();
    }
    else
    {
      push(@instructions2, $instruction_ptr);
    }
    $instruction_ptr = shift(@{$instructions});
  }
  # - left overs
  foreach $instruction_ptr (@instructions2)
  {
    my @instruction = @{$instruction_ptr};
    &printBuffer("Error! Unrecognized instruction \"" . $instruction[0] . ":" . $instruction[1] . "\"\n");
  }
}
else
{
  &printBuffer(" * No Instructions!\n");
}

# 4. Complete!
my $end_time = time();
my $duration = $end_time - $start_time;
&printBuffer("===== Complete in " . $duration . " seconds =====\n");
&printBuffer("[" . localtime($end_time) . "]\n\n");

# 5. Try and write to log path (hopefully before a reboot shuts us down)
#    Needs to be in eval{} in case filesystem is non-responsive
eval
{
  local $SIG{ALRM} = sub { die 'timeout' };
  alarm 5; # This is a lifetime for file writing
  if (open(LOGOUT, '>:utf8', $log_path))
  {
    print LOGOUT $txt_buffer;
    close (LOGOUT);
  }
  else
  {
    print "Error! Failed to open log for writing\n";
  }
  alarm 0;
};
alarm 0;
if (defined $@ && $@ ne '')
{
  print "Error! Failed to write log - " . $@ . ":" . $! . "\n";
}

exit;

## @function
#
sub printBuffer
{
  my ($msg) = @_;
  print $msg;
  if (defined $log_path && $log_path ne '')
  {
    $txt_buffer .= $msg;
  }
}
## printBuffer() ##

## @function commandIsRunning
#
sub commandIsRunning
{
  my ($pid) = @_;
  my $result == 1;
  # yeah - timeout this command too, as I don't know if PS is hang-safe
  eval
  {
    local $SIG{ALRM} = sub { die 'timeout' };
    alarm 5; # This is a lifetime for file writing
    $result = `ps -p $pid > /dev/null; echo $?`;
    chomp($result);
    alarm 0;
  };
  alarm 0;
  if (defined $@ && $@ ne '')
  {
    &printBuffer("[ps timed out] ");
  }
  return ($result == 0);
}
## commandIsRunning() ##

## @function commandReboot
#
# Wait five minutes then reboot the machine
#
sub commandReboot
{
  &printBuffer(" - rebooting\n");
  &printBuffer(&shellCommand('shutdown -r +5', 1));
}
## commandReboot ##

## @function commandSlay
#
sub commandSlay
{
  my ($user) = @_;
  &printBuffer(" - slay all processes by: " . $user . "\n");
  $user =~ s/"//g;
  &printBuffer(&shellCommand('slay -clean "' . $user . '"'));
}
## commandSlay() ##

## @function commandTerminate
#
sub commandTerminate
{
  my ($pid) = @_;
  &printBuffer(" - terminate process: " . $pid . "... ");
  # send SIGTERM
  &printBuffer(&shellCommand('kill -s SIGTERM ' . $pid));
  # wait delay seconds
  sleep($kill_delay);
  # see if process still there
  if (&commandIsRunning($pid))
  {
    &printBuffer("Failed\n");
    &printBuffer(" - kill process: " . $pid . "... ");
    &printBuffer(&shellCommand('kill -s SIGKILL ' . $pid));
    sleep($kill_delay);
    if (&commandIsRunning($pid))
    {
      &printBuffer("Failed\n");
    }
    else
    {
      &printBuffer("Killed\n");
    }
  }
  else
  {
    &printBuffer("Terminated\n");
  }
  # if it is still running then it must be uninterruptable... nothing we can
  # do from here
}
## commandTerminate() ##


## @function parseInstructions
#
sub parseInstructions
{
  my ($content) = @_;
  my $instruction_count = 0;
  while ($content =~ s/(pid|user|cmd)\:([^\s]+)//i)
  {
    my $type = lc($1);
    my $value = $2;
    push(@{$instructions}, [$1, $2]);
    $instruction_count++;
  }
  return $instruction_count;
}
## parseInstructions() ##


## @function printDebug()
#
sub printDebug
{
  my ($msg) = @_;
  if ($debug)
  {
    &printBuffer("[DEBUG] " . $msg . " [" . time() . "]\n");
  }
}
## printDebug() ##


## @function searchPath()
#
sub searchPath
{
  my $result = 0;
  # A user can ask us to do stuff by dumping a file here
  eval
  {
    local $SIG{ALRM} = sub { die 'timeout' };
    alarm $listen_time;
    &printBuffer("[opening... ");
    # read instructions (<type>:<value>\n) from the file
    if (open(FIN, '<:utf8', $search_path))
    {
      &printBuffer("reading... ");
      my $content;
      sysread(FIN, $content, -s $search_path);
      &printBuffer("parsing... ");
      $result = &parseInstructions($content);
      close(FIN);
      # remove the file (if we can)
      &printBuffer("deleting... ");
      unlink($search_path);
      &printBuffer("complete] ");
    }
    else
    {
      &printBuffer("failed] ");
    }
    alarm 0; # reset alarm
  };
  alarm 0; # reset alarm
  if (defined $@ && $@ ne '')
  {
    if ($@ =~ /timeout/)
    {
      &printBuffer("timed out] ");
    }
    else
    {
      &printBuffer("error] ");
    }
  }
  return $result;
}
## searchPath() ##


## @function searchPort
#
sub searchPort
{
  my $result = 0;
  # timeout isn't implemented in Perl sockets, so we cheat and use an alarm
  # that interrupts an eval block
  eval {
    local $SIG{ALRM} = sub { die 'timeout' };
    alarm $listen_time;
    my $socket = IO::Socket::INET->new(Proto     => 'tcp',
                                       LocalPort => $search_port,
                                       Listen    => 1,
                                       ReuseAddr => 1
                                      );
    if (defined $socket)
    {
      &printBuffer("[listening... ");
      while (my $client = $socket->accept())
      {
        &printBuffer("connected... ");
        $client->autoflush(1);
        my $line;
        while ($line = <$client>)
        {
          &printBuffer("receiving... ");
          $result += &parseInstructions($line);
        }
        close $client;
        &printBuffer("complete] [listening... ");
      }
    }
    else
    {
      &printBuffer("failed] ");
    }
    alarm 0; # reset alarm
  };
  alarm 0; # reset alarm
  if (defined $@ && $@ ne '')
  {
    if ($@ =~ /timeout/)
    {
      &printBuffer("timed out] ");
    }
    else
    {
      &printBuffer("error] ");
    }
  }
  return $result;
}
## searchPort() ##


## @function searchURL
#
sub searchURL
{
  my $result = 0;
  &printBuffer("[downloading... ");
  my $content = get($search_url);
  if (defined $content)
  {
    &printBuffer("parsing... ");
    $result = &parseInstructions($content);
    &printBuffer("complete] ");
  }
  else
  {
    &printBuffer("failed] ");
  }
  return $result;
}
## searchURL() ##


## @function shellCommand()
#
sub shellCommand
{
  my ($cmd, $background) = @_;
  my $result = '';
  # timeout all shell commands
  eval
  {
    local $SIG{ALRM} = sub { die 'timeout' };
    alarm 5; # This is a lifetime for file writing
    if ($debug)
    {
      &printDebug('shellCommand(\'' . $cmd . '\')');
    }
    elsif (defined $background)
    {
      $result = `$cmd 2>&1 &`;
    }
    else
    {
      $result = `$cmd 2>&1`;
    }
    alarm 0;
  };
  alarm 0;
  if (defined $@ && $@ ne '')
  {
    &printBuffer("[shell command timed out] ");
  }
  return $result;
}
## shellCommand() ##

__END__
=head1 NAME
sample - Using GetOpt::Long and Pod::Usage
=head1 SYNOPSIS
sample [options] [file ...]
 Options:
   -help            brief help message
   -man             full documentation
=head1 OPTIONS
=over 8
=item B<-help>
Print a brief help message and exits.
=item B<-man>
Prints the manual page and exits.
=back
=head1 DESCRIPTION
B<This program> will read the given input file(s) and do something useful with the contents thereof.
=cut