#!/usr/bin/perl -T

##############################################
# webps - D.M.Ragle
#
# A Web interface to the system ps utility
#
##############################################

use 5.006_000;
use strict;
use warnings;

use CGI ();
use Digest::MD5 qw(md5_hex);
use XML::Simple qw(XMLin);
use HTML::Template ();
use HTML::Entities ();
use Fcntl qw(:flock);

# Some CGI DoS protections
$CGI::POST_MAX = 5000;
$CGI::DISABLE_UPLOADS = 1;

our $VERSION = .20;

# Clear the path (taint requires this)
$ENV{'PATH'} = ':/bin:/usr/bin';

# Force XML::Parser in XML::Simple
$XML::Simple::PREFERRED_PARSER = 'XML::Parser';

# Unbuffer output
$| = 1;

############################
# Configuration section

our $config_dir  = '/www/biblestuph/apps/webps/';
our $ps_command  = '/bin/ps -eo ';

our $config_file = $config_dir . 'webps.xml';
our $tmpl_dir    = $config_dir . 'tmpl/';

# End configuration section
############################

# Initialize CGI object
my $cgi = CGI->new();

# Initialize and scrub configuration 
# variables and CGI parameters
my ($config, $action, $state_file) = init($cgi);

# Create hash of live ps data 
my $live_hash   = {};
my @live_fields = ();
my $psh = undef;
foreach my $field (split(/\s*,\s*/, $config->{'default_fields'})) {
   push(@live_fields, $field);
   open($psh, $ps_command . 'pid,' . $field . ' |') or
      send_error($cgi, 1, 'Cannot access ps.');
   while (my $ps_line = <$psh>) {
      $ps_line = trim($ps_line);
      next unless ($ps_line =~ /^(\d+)\s+(.*)$/);
      my $pid = $1;
      my $val = $2;
      next if (($pid eq $$) && ($config->{'ignore_self'}));
      $val = HTML::Entities::encode_entities($val, '&"<>\'');
      $live_hash->{$pid}->{$field} = $val;
   }
   close $psh or
      send_error($cgi, 2, 'Cannot close ps.');
   $psh = undef;
}

# Some entries may have been transient (were there for
# just a brief moment as the above fields were being 
# interrogated). Remove those here.
PID: foreach my $pid (keys (%{$live_hash}) ) {
   foreach my $field (@live_fields) {
      next if (exists $live_hash->{$pid}->{$field});
      delete $live_hash->{$pid};
      next PID;
   }
}


# Create hash of saved (previous) data
my $state_hash = {};
open(my $sfh, '+<', $state_file) or 
   send_error($cgi, 3, 'Cannot access state file data.');
flock $sfh, LOCK_EX;

my $header_line  = <$sfh>;
if ($header_line) {
   my @state_fields = split(/\t/, trim($header_line));

   while (my $ps_line = <$sfh>) {
      $ps_line = trim($ps_line);
      my @state_values = split(/\t/, $ps_line);
      for (my $i = 1; $i < @state_values; $i++) {
         $state_hash->{$state_values[0]}->{$state_fields[$i]} = $state_values[$i];
      }
   }
}

# Save off state file for next run
# pid is always the first field
seek $sfh, 0, 0;
print $sfh join("\t", 'pid', @live_fields), "\n";
foreach my $pid (keys (%{$live_hash}) ) {
   my $pid_rec = $live_hash->{$pid};
   print $sfh join("\t", $pid, (map { $pid_rec->{$_} } @live_fields)), "\n";
}
truncate($sfh, tell $sfh);
close $sfh;

# Setup loop vars
my @field_loop  = ();
my @add_loop    = ();
my @change_loop = ();
my @delete_loop = ();

my $field_counter = 0;
foreach my $field (split(/\s*,\s*/, $config->{'default_fields'})) {
   my $field_hash = $config->{'fields'}->{'tag'}->{'field_' . $field};
   push(@field_loop, {'field_name'    => translate_field($field),
                      'field_label'   => $field_hash->{'label'},
                      'field_order'   => $field_counter++,
                      'field_justify' => $field_hash->{'justify'} || 'left'});
}

foreach my $pid (keys (%{$live_hash})) {
   if (exists $state_hash->{$pid}) {
      # Update logic
      my $live_pid  = $live_hash->{$pid};
      my $state_pid = $state_hash->{$pid};
      my @pid_loop  = ();
      foreach my $field (keys (%{$live_pid}) ) {
         push(@pid_loop, {'field_name'  => translate_field($field), 
                          'field_value' => $live_pid->{$field} })
            unless ((exists $state_pid->{$field}) &&
                    $live_pid->{$field} eq $state_pid->{$field});
      }
      push(@change_loop, {'pid'      => $pid,
                          'pid_loop' => \@pid_loop})
         if (@pid_loop);
   }
   else {
      push(@add_loop, {'pid'      => $pid, 
                       'pid_loop' => [map { {'field_name'  => translate_field($_), 
                                             'field_value' => $live_hash->{$pid}->{$_}} } (keys (%{$live_hash->{$pid}}))]});
   }
}
foreach my $pid (keys (%{$state_hash})) {
   push(@delete_loop, {'pid' => $pid})
      unless (exists $live_hash->{$pid});
}

start($cgi, 
      $config, 
      \@field_loop,
      \@add_loop)     if ($action eq 'start');

update($cgi, 
       $config,
       \@field_loop,
       \@add_loop, 
       \@change_loop, 
       \@delete_loop) if ($action eq 'update');

##############################################
# start
#
# Provide the initial web pages that start the
# ps listings
#
sub start {
   my ($cgi, $config, 
       $field_loop, $add_loop) = @_;

   my $sort_field  = '';
   my @field_order = ();

   foreach my $field (split(/\s*,\s*/, $config->{'default_fields'})) {
      $field = translate_field(trim($field));
      push(@field_order, {'field_name' => $field});
      $sort_field = 'pid' if ($field eq 'pid');
   }
   $sort_field = $field_order[0] unless ($sort_field);

   my @allowed_fields = map { {'field_name' => trim($_)} } (sort(split(/\s*,\s*/, $config->{'allowed_fields'})));

   my $template = get_template('mainpage.tmpl');
   $template->param('max_fields'     => $config->{'max_fields'} || 0,
                    'min_interval'   => $config->{'min_interval'},
                    'field_order'    => \@field_order,
                    'allowed_fields' => \@allowed_fields,
                    'sort_field'     => $sort_field,
                    'add_loop'       => $add_loop, 
                    'field_loop'     => $field_loop,
                    'script_name'    => $cgi->url(),
                    'session_id'     => $cgi->param('session')  || '',
                    'username'       => $cgi->param('username') || '');
   print $template->output;
}
#
# end start
##############################################

##############################################
# update
#
# Provide an incremental update for this user
#
sub update {
   my ($cgi, $config, 
       $field_loop, $add_loop, 
       $change_loop, $delete_loop) = @_;

   my $template = get_template('update.' . $cgi->param('reqtype'));

   $template->param('refresh_rate' => $config->{'min_interval'},
                    'add_loop'     => $add_loop, 
                    'field_loop'   => $field_loop,
                    'change_loop'  => $change_loop,
                    'delete_loop'  => $delete_loop);
   print $template->output;
}
#
# end update
##############################################

##############################################
# init
#
# Initialization routines. This scrubs both
# the configuration file parameters and the 
# CGI parameters. It returns the config hash
# (hash representation of the contents of the
# configuration file).
#
sub init {
   my $cgi = shift;

   # Reqtype must be 'html' or 'xml'
   $cgi->param(-name => 'reqtype', -value => 'html')
      unless ($cgi->param('reqtype') &&
             ($cgi->param('reqtype') eq 'xml'));
   
   # Check for error templates; this will generate 
   # a hard coded error response if it fails (since we 
   # can't access the templates)
   unless ((-e $tmpl_dir . 'error.html') && (-r _) &&
           (-e $tmpl_dir . 'error.xml')  && (-r _)) {
      cgi_header($cgi);
      if ($cgi->param('reqtype') eq 'xml') {
         print '<?xml version="1.0" encoding="utf-8"?>', "\n";
         print '<webps>', "\n";
         print '   <error_code>1</error_code>', "\n";
         print '   <error_message>Template Directory does not exist or is not accessible</error_message>', "\n";
         print '</webps>';
      }
      else {
         print '<h2>webps Error 1: Template Directory does not exist or is not accessible</h2>';
      }
      exit;
   }

   # Retrieve the configuration file
   send_error($cgi, 4, 'Cannnot access configuration file')
      unless ((-e $config_file) && (-r _));

   my $config = '';
   eval { $config = XMLin($config_file, suppressempty => 1,
                                        forcearray => ['user'] ) };
   send_error($cgi, 5, 'Cannnot initialize configuration parameters')
      if ($@ or (ref $config ne 'HASH'));

   # Scrubbing for top level configuration settings
   if ($config->{'admin_email'} =~ /^([-\w.~+]+@([-\w]+\.)+[A-Za-z]{2,4})$/) {
      $config->{'admin_email'} = $1;
   }
   else {
      send_error($cgi, 6, 'Configuration error: E-mail address invalid.');
   }

   foreach my $path (qw(data_dir tmpl_dir session_file)) {
      send_error($cgi, 7, 'Configuration error: ' . $path . ' is incorrectly formatted (1).')
          if ($config->{$path} =~ m%/\.+(/|$)%);
      send_error($cgi, 8, 'Configuration error: ' . $path . ' is incorrectly formatted (2).')
          unless ($config->{$path} =~ m%^([A-Za-z]+\:)?/%);
   }

   # Must be at least one user defined
   send_error($cgi, 29, 'Configuration error: No users defined.')
      unless (exists $config->{'user'}); 

   # All user names/passwords must be valid
   foreach my $user (keys %{$config->{'user'}}) {
      send_error($cgi, 30, 'Configuration error: Invalid user name.') 
         unless ($user =~ /^[\w &#;]+$/);
      send_error($cgi, 31, 'Configuration error: Invalid user password.') 
         unless ((exists $config->{'user'}->{$user}->{'password'})              &&
                 ($config->{'user'}->{$user}->{'password'} =~ /^[a-f0-9]{32}$/) &&
                 ($config->{'user'}->{$user}->{'password'} ne md5_hex('')));
   }

   # Reset template directory from configuration file
   $tmpl_dir = $config->{'tmpl_dir'};

   foreach my $num (qw(max_sessions min_interval session_timeout
                      max_session_length)) {
      $config->{$num} =~ s/^0+//;
      send_error($cgi, 9, 'Configuration error: ' . $num . ' is incorrectly formatted.')
         unless ($config->{$num} =~ m%^\d+$%);
   }

   # Create the data directory, if it doesn't already exist
   unless (-d $config->{'data_dir'}) {
      send_error($cgi, 10, 'Cannot make data directory.')
         unless (mkdir($config->{'data_dir'}, 0700));
   }

   # Make sure data directory is accessible
   send_error($cgi, 11, 'Insufficient access rights on data directory.')
      unless ((-d $config->{'data_dir'}) &&
              (-r _) && (-w _));

   # Make session file, it it doesn't already exist
   unless (-e $config->{'session_file'}) {
      open (my $fh, '>', $config->{'session_file'}) or
         send_error($cgi, 12, 'Cannot create session file.');
      close $fh;
      $fh = undef;
      chmod(0700, $config->{'session_file'}) or
         send_error($cgi, 13, 'Cannot set access rights on session file.');
   }
   send_error($cgi, 14, 'Cannot access session file.')
      unless (-e $config->{'session_file'} && -r _ && -w _);

   # Retrieve session data
   my @sessions = ();
   open (my $session_file, '+<', $config->{'session_file'}) or
      send_error($cgi, 15, 'Cannot open session file.');
   flock $session_file, LOCK_EX;
   while (my $session = <$session_file>) {
      chomp($session);
      my ($id, $epoch, $username, $start_time) = split(',', $session);
      $start_time = 0 unless ($start_time);
      if (((time() - $epoch) <= $config->{'session_timeout'}) &&
          ((time() - $start_time) <= $config->{'max_session_length'})) {
         push (@sessions, $session)
      }
      else {
         if ($id =~ /^([a-f0-9]{32})$/) {
            $id = $1;
            unlink($config->{'data_dir'} . $id . '.txt')
               if (-e $config->{'data_dir'} . $id . '.txt');
         }
      }
   }

   # Some prep variables
   my $username   = $cgi->param('username') || '';
   my $password   = $cgi->param('password') || '';
   my $session_id = $cgi->param('session')  || '';

   $username      = to_entities($username);
   $password      = to_entities($password);

   if ($session_id =~ /^([a-f0-9]{32})$/) {
      $session_id = $1;
   }
   else {
      $session_id = '';
   }

   my $login_msg  = ($cgi->param('reqtype') eq 'xml') ? 
                    'User authentication required.' : '';
   my $state_file = '';

   # Authenticate the user. This is either via their 
   # session ID or username/password
   $cgi->param(-name => 'authenticated', -value => 0);

   if ($username && $password) {
      if (exists $config->{'user'}->{$username} &&
          md5_hex($password) eq $config->{'user'}->{$username}->{'password'}) {
         $cgi->param(-name => 'authenticated', -value => 1);
         $cgi->param(-name => 'username', -value => $username);
         $login_msg = '';

         if ($session_id) {
            $state_file = $config->{'data_dir'} . $session_id . '.txt';
            untaint($state_file);
            if (-e $state_file) {
               send_error($cgi, 16, 'Cannot remove previous state file.')
                  unless unlink($state_file);
            }
         }
      }
      else {
         $login_msg = 'Invalid username or password.';
      }
   }

   if ($session_id) {
      foreach my $session (@sessions) {
         my ($id, $epoch, $user, $start_time) = split(',', $session);
         $start_time = 0 unless ($start_time);
         if (($id eq $session_id)                && 
             (exists $config->{'user'}->{$user}) &&
             ((time() - $epoch) >= $config->{'min_interval'})) {
            unless ($cgi->param('authenticated')) {
               $cgi->param(-name => 'username', -value => $user);
               $cgi->param(-name => 'authenticated', -value => 1);
            }
            $epoch = time();
            $session = join(',', $id, $epoch, $user, $start_time);
            $login_msg = '';
         }
         elsif (($id eq $session_id)                && 
                (exists $config->{'user'}->{$user}) &&
                ((time() - $epoch) < $config->{'min_interval'})) {
            unless ($cgi->param('authenticated')) {
               $cgi->param(-name => 'username', -value => $user);
               $cgi->param(-name => 'authenticated', -value => 1);
            }
            $login_msg = 'Refresh rate exceeded. Please try again in a moment.';
         }
      }
      $login_msg = 'Session has expired. Please re-login.'
         unless ($cgi->param('authenticated'));
   }

   if ($cgi->param('authenticated')) {

      unless ($session_id) {
         $session_id = get_session_id();
         $cgi->param(-name => 'session', -value => $session_id);
         push(@sessions, join(',', $session_id, time(), $cgi->param('username'), time()));
      }

      # Check max sessions
      if ($config->{'max_sessions'} < scalar(@sessions)) {
         close $session_file;
         send_error($cgi, 17, 'Too many active sessions. Please try again later.');
      }

      unless ($state_file) {
         $state_file = $config->{'data_dir'} . $session_id . '.txt';
         untaint($state_file);
      }

      cgi_header($cgi);
      seek $session_file, 0, 0;
      foreach my $session (@sessions) {
         print $session_file $session, "\n";
      }
      truncate($session_file, tell $session_file);
      close $session_file;
      $session_file = undef;
   }
   else {
      close $session_file;
      $session_file = undef;

      if ($cgi->param('reqtype') eq 'xml') {
         send_error($cgi, 18, $login_msg);
      }
      else {
         cgi_header($cgi);

         my $template = get_template('login_form.tmpl');
         $template->param(version     => $VERSION,
                          admin_name  => $config->{'admin_name'}  || '',
                          admin_email => $config->{'admin_email'} || '',
                          message     => $login_msg,
                          script_name => $cgi->url());
         print $template->output;

         exit;
      }
   }

   send_error($cgi, 19, $login_msg) if ($login_msg);

   # User is authenticated. 
   $username = $cgi->param('username');

   # If a field_set was passed in, it becomes the 
   # default set for this user
   if ($cgi->param('field_set')) {
      my @fields = map { translate_field(trim($_)) } 
                             split(/\s*,\s*/, $cgi->param('field_set'));
      $config->{'user'}->{$username}->{'default_fields'} = join(',', @fields);
   }

   # Roll up the appropriate user-specific 
   # configuration parameters
   foreach my $key (qw(default_fields allowed_fields 
                      max_fields ignore_self)) {
      $config->{$key} = $config->{'user'}->{$username}->{$key}
         if (exists ($config->{'user'}->{$username}->{$key}));
   }

   # Now finish the config parameter scrubbing       
   foreach my $num (qw(max_fields)) {
      $config->{$num} =~ s/^0+//;
      send_error($cgi, 20, 'Configuration error: ' . $num . ' is incorrectly formatted.')
         unless ($config->{$num} =~ m%^\d+$%);
   }

   foreach my $num (qw(ignore_self)) {
      send_error($cgi, 21, 'Configuration error: ' . $num . ' is incorrectly formatted.')
         unless ($config->{$num} =~ m%^(1|0)$%);
   }

   # Create the allowed fields setting if it doesn't already exist
   unless (exists $config->{'allowed_fields'}) {
      my $allowed_fields = '';
      foreach my $key (keys %{$config->{'fields'}->{'tag'}}) {
         $key =~ s/^field_//;
         $allowed_fields .= $key . ',';
      }
      $allowed_fields =~ s/,$//;
      $config->{'allowed_fields'} = $allowed_fields;
   }

   # Default fields must be <= max fields
   my @field_count = split(/\s*,\s*/, $config->{'default_fields'});
   send_error($cgi, 22, 'Too many fields requested. Please limit the number of fields requested to ' . 
                       $config->{'max_fields'} .
                       ' or less.')
      if (@field_count > $config->{'max_fields'});

   # Each field for this user (both default and allowed) 
   # must exist in the fields collection 
   foreach my $field_set (qw(default_fields allowed_fields)) {
      foreach my $field (split(/\s*,\s*/, $config->{$field_set})) {
         $field = trim($field);
         send_error($cgi, 23, 'Invalid field choice for user (' . $field . ').')
            unless (exists $config->{'fields'}->{'tag'}->{'field_' . $field});
      }
   }

   # Each of the default fields--which at this point 
   # represent the exact field list that will be reported 
   # to the user--must exist in the allowed fields list
   my %allowed_fields = map { $_ => 1 } (split(/\s*,\s*/, $config->{'allowed_fields'}));
   foreach my $selected_field (split(/\s*,\s*/, $config->{'default_fields'})) {
      send_error($cgi, 24, 'Invalid field choice for user (' . $selected_field . ').')
         unless ($allowed_fields{$selected_field});
   }

   # Ensure the session specific state file for
   # this user can accessed and/or created
   unless (-e $state_file) {
      open(my $sfh, '>', $state_file) or
         send_error($cgi, 25, 'Cannot open state file for user (1).');
      close $sfh;
      chmod(0700, $state_file) or
         send_error($cgi, 26, 'Cannot set access rights on state file.');
   }
   send_error($cgi, 27, 'Cannot open state file for user (2).')
      unless (-r $state_file && -w _);

   untaint_configs($config);

   # Scrub the action
   my $action = $cgi->param('action') || 'start';
   if ($action =~ /^(start|update)$/) {
      $action = $1;
   }
   else {
      send_error($cgi, 28, 'Illegal action');
   }

   return ($config, $action, $state_file);
}
#
# end init
##############################################

##############################################
# get_session_id
#
# Returns a random string suitable for use as
# a session id
#
sub get_session_id {

   my @_hash_alphabet = map chr($_), 0..255;
   my $_hash_length   = 60;

   my $hash = join('', map $_hash_alphabet[rand 256], 1..$_hash_length);
      $hash = lc(md5_hex($hash));

   return $hash;
}
#
# end get_session_id
##############################################

##############################################
# cgi_header
#
# Prints the appropriate CGI header for output
#
sub cgi_header {
   my ($cgi, $cookies) = @_;

   return if ($cgi->param('header_written'));

   # Print the right header based on what they 
   # requested (html or xml)
   if ($cookies) {
      print $cgi->param('reqtype') eq 'xml' ? 
         $cgi->header(-cookie => $cookies,
                      -type   => 'text/xml; charset=utf-8') : 
         $cgi->header(-cookie => $cookies);
   }
   else {
      print $cgi->param('reqtype') eq 'xml' ? 
         $cgi->header(-type   => 'text/xml; charset=utf-8') : 
         $cgi->header();
   }
   $cgi->param(-name  => 'header_written', 
               -value => 1);

   return;
}
#
# end cgi_header
##############################################

##############################################
# send_error
#
# This function will send an error message and
# code (passed in) back to the user. The 
# The message is sent in either XML or HTML 
# format; depending on what type of request 
# the user made in the first place. THIS 
# FUNCTION DOES NOT RETURN.
#
# Note that this function should be minimal; 
# don't include configuration information in
# it since we may not have access to the 
# config file when we call it.
#
sub send_error {
   my ($cgi, $code, $message) = @_;

   cgi_header($cgi);

   my $template = get_template('error.' . $cgi->param('reqtype'));

   $template->param(code    => $code,
                    message => $message);
   print $template->output;

   exit;
}
#
# end send_error
##############################################

##############################################
# get_template
#
# Opens an HTML template and returns the 
# object to the caller
#
sub get_template {
   my $template_file = shift;
   return HTML::Template->new(filename => $tmpl_dir . $template_file,
                              die_on_bad_params => 0,
                              loop_context_vars => 1);
}
#
# end get_template
##############################################

##############################################
# untaint_configs
#
# Recursive routine that examines the 
# returned configuration file data, trims, and 
# untaints it
#
#
sub untaint_configs {
   my $config_ref = shift;
   foreach my $val ((ref $config_ref eq 'HASH') ? values(%{$config_ref}) : @{$config_ref}) {
      my $key = (ref $config_ref eq 'HASH') ? each(%{$config_ref}) : '';
      if (ref $val) {
         untaint_configs($val);
      }
      else {
         $val = trim($val);
         untaint($val) 
            unless ($key && (($key eq 'admin_email') || ($key eq 'user')));
      }
   }
}
#
# end untaint_configs
##############################################

##############################################
# to_entities
#
# cleanses provided strings, replacing all 
# but typical ASCII characters with HTML 
# entity representations and returning the 
# cleansed string.
#
sub to_entities {
   my $data = shift;
      $data =~ s/([^\x0a\x0d\x20-\x7f])/'&#' . ord($1) . ';'/ges;
   return $data;
}
#
# end to_entities
##############################################

##############################################
# trim
#
# trim leading and trailing white space from 
# a string. Returns the trimmed string.
#
sub trim {
   my $data = shift;
      $data =~ s/^\s+//;
      $data =~ s/\s+$//;
   return $data;
}
#
# end trim
##############################################

##############################################
# translate_field
#
# Translates a field name into a more JS 
# friendly form. Will be used on all field 
# designators sent the client (but internally
# we still use regular field names). Translation
# happens in both directions here.
#
sub translate_field {
   my $field_to_translate = shift;
   if ($field_to_translate =~ /[A-Z]/) {
      $field_to_translate =~ tr/PU/\%_/;
   }
   else {
      $field_to_translate =~ tr/\%_/PU/;
   }
   return $field_to_translate;
}
#
# end translate_field
##############################################

##############################################
# untaint
#
# Strips metacharacters from a string and 
# declares it safe (untaints it). Operates 
# on the variable in place.
#
sub untaint {
    $_[0] =~ s/[][&;`'\\"|*?~<>^(){}\$\n\r]//gs;
   ($_[0] =~ /^(.*)$/) && ($_[0] = $1);
} 
#
# end untaint
##############################################