Basic Perl Tk HTTP Server Monitor

Here's a port of my simple Python HTTP Server Monitor to Perl, using the Tkx module to interface with Tk. A minor difference is to use the Tk options database to specify the font of the headers in a configuration file.

# Basic HTTP Server Monitor by Kam-Hung Soh 2008.
use strict;
use warnings;
use Log::Log4perl qw(:easy);
use LWP::Simple;
use Text::CSV;
use POSIX;
use Tkx;

use constant CONFIGURATION_PATH => 'HttpServerMonitor.csv';
use constant LOG_PATH           => 'HttpServerMonitor.log';
use constant OPTION_PATH        => 'HttpServerMonitor.db';
use constant REFRESH_INTERVAL   => 60000; # Miliseconds
use constant TIME_FORMAT        => '%H:%M:%S %d-%m-%y';

sub create_widgets {
  my $logger = get_logger;
  my $app = Tkx::widget->new('.');
  Tkx::wm_title($app, 'HTTP Server Monitor');
  my $col = 0;
  for my $text ('Name', 'Host', 'Port', 'Status', 'Last Check') {
    $app->new_label(-name => 'header' . $col, -text => $text)
      ->g_grid(-row => 0, -column => $col, -padx => 2, -pady => 2);
    $col++;
  }

  my $row = 1;
  my $csv = Text::CSV->new;
  open CSV, "<", CONFIGURATION_PATH;
  ; # Skip header row
  while () {
    $logger->debug('$. = ' . $.);
    if ($csv->parse($_)) {
      my @field = $csv->fields;
      $col = 0;
      for my $s (@field) {
        $app->new_label(-text => $s)
          ->g_grid(-row => $row, -column => $col, -padx => 2, -pady => 2, -sticky => 'W');
        $col++;
      }
      my ($name, $host, $port) = @field;
      my $key = $host . ':' . $port;
      $::status_label{$key} = $app->new_label(-background => 'yellow', -text => 'unknown');
      $::status_label{$key}->g_grid(-row => $row, -column => $col, -padx => 2, -pady => 2, -sticky => 'W');
      $::time_label{$key} = $app->new_label(-text => strftime TIME_FORMAT, localtime);
      $::time_label{$key}->g_grid(-row => $row, -column => $col+1, -padx => 2, -pady => 2, -sticky => 'W');
    }
    $row = $.;
  }
  close CSV;

  $app->new_button(-text => "Refresh", -command => \&refresh)
    ->g_grid(-row => $row, -column => 4, -padx => 2, -pady => 2, -sticky => 'E');
}

sub refresh {
  my $logger = get_logger;
  for my $key (keys %::status_label) {
    my $url = 'http://' . $key;
    $logger->debug($url);
    if (head $url) {
      $::status_label{$key}->configure(-background => 'green', -text => 'up');
    } else {
      $::status_label{$key}->configure(-background => 'red', -text => 'down');
    }
    $::time_label{$key}->configure(-text => strftime TIME_FORMAT, localtime);
  }
  Tkx::after(REFRESH_INTERVAL, \&refresh);
}

Log::Log4perl->easy_init($INFO);
my $logger = get_logger;
$logger->info('Start');
Tkx::option_readfile(OPTION_PATH);
create_widgets;
refresh;
Tkx::MainLoop;
$logger->info('Finish');

This script reads a list of servers in CONFIGURATION_PATH to monitor from a CSV file with three columns, the display name, the host name and the port, such as the one below:

Name,Host,Port
Google,google.com.au,80

When the script starts, it reads Tk widget configuration from an Xdefaults-style file in OPTION_PATH, such as the one below. Note that according to Options and Tk - A Beginner's Guide, you can't set grid options (that's why the script is peppered with padx and pady options).

*header0.font : -size 10 -weight bold
*header1.font : -size 10 -weight bold
*header2.font : -size 10 -weight bold
*header3.font : -size 10 -weight bold
*header4.font : -size 10 -weight bold

The Tk configuration file is more verbose than I expected. Each widget in Tk belongs in a container, containers can be members of other containers, and all widgets belong to a root container (similar to a file system). In each line of a Tk configuration file, you specify the path to a widget (all text up to the last dot), the option (the text between the last dot and colon) and the value to use (the text after the column).

!---- pathname ---+ +option+     +----- value -------+
application.header0.font       : -size 10 -weight bold

You can use an asterisk in the widget pathname if you don't care about the container of the widget. However, there's no wildcard for the widget's name, so in this case, I have to enumerate each widget that I want to configure.

See Also

• Python HTTP Server Monitor
• Options and Tk - A Beginner's Guide