[perl] Script that tracks log files and domain registrations and alerts on problems

alert.pl

#!/usr/bin/perl

use strict;
use warnings;
use 5.010;

use POSIX;
use Fcntl;

use threads;

use Tracker;
use Domains;
use Logs;

use constant NAME => 'alert';
use constant VERSION => '1.0';

my %track = (
	'/var/log/xenctrlserver/xenctrlserver.log' => \&Logs::base,
	'/var/log/wwdserver/wwdserver.log' => \&Logs::base
);

die 'Usage: '.NAME."\n" if ($#ARGV != -1);

# Disable starting multiple instances
sysopen RUN, '/var/run/'.NAME.'.pid', O_CREAT | O_WRONLY, 0600;
flock(RUN, Fcntl::LOCK_EX | Fcntl::LOCK_NB)
	or die NAME.": Application already running\n";

# Daemonize
exit if fork;
POSIX::setsid;
chdir '/';
umask 0;

# Write PID to a file
truncate RUN, 0;
print RUN "$$\n";

open STDIN, '<', '/dev/null';
open STDOUT, '>', '/dev/null';
sysopen STDERR, '/var/log/'.NAME.'.log', O_CREAT | O_APPEND | O_WRONLY, 0600;
select STDERR;
$| = 1; # Disable output buffering

# Ignore signals that may terminate the program
$SIG{'ALRM'} = 'IGNORE';

# Start a separate thread to track each file
my @threads = ();
foreach my $filename (keys %track)
{
	my $handler = $track{$filename};
	my $tracker = Tracker::new($filename);
	if (!defined($tracker))
	{
		Report::log(NAME.": Unable to track $filename");
		next;
	}
	push @threads, threads->new(sub {$tracker->track($handler);});
	$threads[$#threads]->detach;
}

# Watch domain registrations and renewals
Domains::watch;

# Avoid program termination if the main thread reaches this point
# Sleep endlessly so that the other threads can do their job
sleep while 1;

Domains.pm

#!/usr/bin/perl

use strict;
use warnings;
use 5.010;

package Domains;
our $VERSION = '1.0';

use DBI;
use Net::Whois::Raw;

use Report;

use constant SQL_SERVER => 'DBI:mysql:schema';
use constant SQL_USERNAME => 'username';
use constant SQL_PASSWORD => 'password';

use constant SECONDS_HOUR => 3600;

use constant RETRY_INTERVAL => 60;

$Net::Whois::Raw::OMIT_MSG = 1;
$Net::Whois::Raw::TIMEOUT = 8;

sub tld
{
	(shift =~ /\.([a-z]+$)/i)[0];
}

# Returns expiration date as (year, month, day)
sub extract_date
{
	sub month_to_number
	{
		my %months = qw(
			jan 1
			feb 2
			mar 3
			apr 4
			may 5
			jun 6
			jul 7
			aug 8
			sep 9
			oct 10
			nov 11
			dec 12
		);

		my $month = lc(shift);
		$months{$month} or $month;
	}

	my $response = shift;
	my @match;

	# TODO: handle two digit years

	# Find the expiration date. Look for several different formats
	@match = ($response =~ /expir.*?(\d{2}|\d{4})[\/-](\d{2}|\w{3})[\/-](\d{2}|\d{4})/i);
	return 0 if (!@match);
	@match = reverse(@match) if ($match[0] < 100);

	$match[0] = 2000 + $match[0] % 100;
	$match[1] = month_to_number($match[1]);
	@match;
}

sub sooner
{
	my ($new, $old) = @_;
	return (($new->[0] > $old->[0]) or ($new->[1] > $old->[1]) or ($new->[2] > $old->[2]));
}

sub expire_date
{
	my $domain = shift;
	my @result = (`/root/wwdsoapserver/wwdserver expire $domain 2> /dev/null` =~ /EXPIRE="(\d+)-(\d+)-(\d+)"/);
	return @result;
}

sub watch
{
	my ($db_query, $db_update, @db_result);
	my @errors;

	# Check domains every hour
	my $start = time;
	while (1)
	{
		my $db = DBI->connect(SQL_SERVER, SQL_USERNAME, SQL_PASSWORD);
		if (!$db)
		{
			Report::log('Unable to connect to database');
			sleep RETRY_INTERVAL;
			next;
		}

		# Check the newly registered domains
		$db_query = $db->prepare('select domain_name from domains_owner where date_sub(now(), interval 1 hour)>=Registered and Registered>=date_sub(now(), interval 25 hour)');
		$db_query->execute;
		@db_result = @{$db_query->fetchall_arrayref};
		foreach my $row (@db_result)
		{
			if (!expire_date($row->[0]))
			{
				my $message = "Not registered: $row->[0]";
				Report::log($message);
				push @errors, $message;
			}

			sleep 1; # Wait to avoid overloading the server
		}
		$db_query->finish;

		# Check the renewed domains
		$db_query = $db->prepare('select domain,date_old from checkrenew where date_old=date_new and checked=0');
		$db_query->execute;
		@db_result = @{$db_query->fetchall_arrayref};
		foreach my $row (@db_result)
		{
			#my $tld = Domains::tld($domain);
			#exit if ($tld eq 'eu');
			#my @date_expire = extract_date(whois($row->[0]));

			my @date_expire = expire($row->[0]);
			if (sooner(@date_expire, split(/-/, $row->[1])))
			{
				my $expire = join('-', @date_expire);

				$db_update = $db->prepare('update checkrenew set checked=1,date_new=? where domain=?');
				$db_update->execute($expire, $row->[0]);
				$db_update->finish;

				$db_update = $db->prepare('update domains_owner set Expires_On=? where domain_name=?');
				$db_update->execute($expire, $row->[0]);
				$db_update->finish;
			}
			else
			{
				my $message = "Not renewed: $row->[0]";
				Report::log($message);
				push @errors, $message;
			}

			sleep 1; # Wait to avoid overloading the server
		}
		$db_query->finish;

		$db->disconnect;

		if (@errors)
		{
			Report::email('[ALERT] Domains', join("\n", @errors));
			@errors = ();
		}

		# WARNING: This assumes that one iteration of the cycle takes less than 1 hour
		sleep(SECONDS_HOUR - (time - $start) % SECONDS_HOUR);
	}
}

1;

Logs.pm

#!/usr/bin/perl

use strict;
use warnings;
use 5.010;

package Logs;
our $VERSION = '1.0';

use Report;

sub base
{
	my ($filename, $log) = @_;
	my @errors;

	foreach (@$log)
	{
		# Remember and log each line containing errors
		when (/error/i)
		{
			push @errors, $_;
			Report::log($_);
		}
	}

	# If errors were found, report them via email
	Report::email("[ALERT] $filename", join("\n", @errors)) if @errors;
}

Report.pm

#!/usr/bin/perl

use strict;
use warnings;
use 5.010;

package Report;
our $VERSION = '1.0';

use constant EMAIL_HOST => 'localhost';
use constant EMAIL_FROM => 'support@webconnect.bg';
use constant EMAIL_TO => 'reports@webconnect.bg';

use Net::SMTP;

sub email
{
	my ($subject, $message) = @_;

	my $smtp = Net::SMTP->new(EMAIL_HOST);
	$smtp->mail(EMAIL_FROM);
	$smtp->recipient(EMAIL_TO);

	$smtp->data;
	$smtp->datasend('From: '.EMAIL_FROM."\n");
	$smtp->datasend('To: '.EMAIL_TO."\n");
	$smtp->datasend("Subject: $subject\n");
	$smtp->datasend("\n");
	$smtp->datasend($message);
	$smtp->dataend;

	$smtp->quit;
}

sub log
{
	my @months = qw(January February March April May June July August September October November December);

	my ($sec, $min, $hour, $day, $month) = localtime(time);
	print sprintf("[%s %02u %02u:%02u:%02u] %s\n", $months[$month], $day, $hour, $min, $sec, shift);
}

1;

Tracker.pm

#!/usr/bin/perl

use strict;
use warnings;
use 5.010;

package Tracker;
our $VERSION = '1.0';

use Fcntl;
use File::stat;

use constant REFRESH_INTERVAL => 5;
use constant RESTART_INTERVAL => 60;

sub new
{
	my $filename = shift;

	# Remember file size and modification time. We have to look only for newly added lines.
	my $stat = stat($filename);
	return undef unless defined $stat;

	bless {'filename' => $filename, 'size' => $stat->size, 'mtime' => $stat->mtime};
}

# Restart tracking when necessary
sub restart
{
	my $self = shift;
	my $stat;

	# Retry to stat until it succeeds
	do
	{
		sleep RESTART_INTERVAL;
		$stat = stat($self->{'filename'});
	} until (defined($stat));

	$self->{'size'} = $stat->size;
	$self->{'mtime'} = $stat->mtime;
}

# Finds newly added to the log file lines
sub refresh
{
	my $self = shift;

	my $stat = stat($self->{'filename'});
	return undef unless defined $stat;

	# Open the file only if the modification time changed
	if ($stat->mtime > $self->{'mtime'})
	{
		open INPUT, '<'.$self->{'filename'};

		# If file length has decreased, it's probably a new file so read the whole file
		$self->{'size'} = 0 if ($self->{'size'} > $stat->size);

		# Read from the position where the new content starts
		seek INPUT, $self->{'size'}, Fcntl::SEEK_SET;
		my @lines = <INPUT>;
		map chomp, @lines; # Drop the line feeds at the end of each line

		close INPUT;

		# Remember size and modification time
		$self->{'size'} = $stat->size;
		$self->{'mtime'} = $stat->mtime;

		return \@lines;
	}

	return [];
}

sub track
{
	my ($self, $handler) = @_;
	while (1)
	{
		# Check for new content in the log file
		my $recent = $self->refresh;
		if (!defined($recent))
		{
			Report::log("alert: Unable to track $self->{'filename'}");
			$self->restart;
			Report::log("alert: Tracking $self->{'filename'} restarted");
		}
		else
		{
			$handler->($self->{'filename'}, $recent);
		}
		sleep REFRESH_INTERVAL;
	}
}

1;