#!/usr/bin/perl -w
############################################################
#
#   $Id: mod_perl.pl 965 2007-03-01 19:11:23Z nicolaw $
#   mod_perl.pl - Example script bundled as part of RRD::Simple
#
#   Copyright 2006 Nicola Worthington
#
#   Licensed under the Apache License, Version 2.0 (the "License");
#   you may not use this file except in compliance with the License.
#   You may obtain a copy of the License at
#
#       http://www.apache.org/licenses/LICENSE-2.0
#
#   Unless required by applicable law or agreed to in writing, software
#   distributed under the License is distributed on an "AS IS" BASIS,
#   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#   See the License for the specific language governing permissions and
#   limitations under the License.
#
############################################################

umask(0022);

use 5.8.3;
use strict;
use LWP::UserAgent;
use RRD::Simple "1.34";
use RRDs;
use File::Spec;
use Socket;
use File::Spec::Functions qw(catdir);
use Time::HiRes qw();

use constant TIMEOUT => 5;
use constant RRDDIR  => '/var/tmp';
use constant IMGDIR  => '/var/tmp';
use constant HOSTS => qw(
				mod_perl1.london.company.com
				mod_perl2.london.company.com
				mod_perl3.london.company.com
				mod_perl1.paris.company.com
				mod_perl2.paris.company.com
			);

use vars qw($VERSION $DEBUG $VERBOSE);
$VERSION = '0.02' || sprintf('%d', q$Revision: 965 $ =~ /(\d+)/g);
$DEBUG = $ENV{DEBUG} ? 1 : 0;
$VERBOSE = $ENV{VERBOSE} ? 1 : 0;

$| = 1;
$RRD::Simple::DEFAULT_DSTYPE = 'GAUGE';

our $ua = user_agent();
our $rrd = new RRD::Simple;



for my $host (sort loc_server HOSTS) {
	my $logs = {};

	TRACE("Processing $host ...");
	my $start_time = Time::HiRes::time();
	my $msg = "Processing $host";
	$VERBOSE && printf('%s %s ', $msg, '.' x (79 - length($msg) - 10));

	my ($status,$scoreboard) = parse_apache_status($ua,
			"http://$host:80/server-status?auto");
	my ($modules) = parse_perl_status($ua,
			"http://$host:80/perl-status?inc");
	$logs = parse_statlogs($ua, "http://$host:80/perl/statlogs.pl")
			unless keys(%{$logs});

	my %rrdfile = (
			status     => catdir(RRDDIR,"$host-status.rrd"),
			scoreboard => catdir(RRDDIR,"$host-scoreboard.rrd"),
			modules    => catdir(RRDDIR,"$host-modules.rrd"),
			logs       => catdir(RRDDIR,"$host-logs.rrd"),
		);

	if (keys %{$status}) {
		$status->{ReqPerSec} = $status->{TotalAccesses};
		$status->{KBPerSec} = $status->{TotalkBytes};

		if (!-f $rrdfile{status}) {
			my %def = %{$status};
			for (keys %def) {
				$def{$_} = $_ =~ /^ReqPerSec|KBPerSec$/i ?
						'DERIVE' : 'GAUGE';
			}

			eval {
				$rrd->create($rrdfile{status}, %def);
				RRDs::tune($rrdfile{status},'-i','ReqPerSec:0','-d','ReqPerSec:DERIVE');
				RRDs::tune($rrdfile{status},'-i','KBPerSec:0','-d','KBPerSec:DERIVE');
			};
			warn $@ if $@;
		}

		eval { $rrd->update($rrdfile{status}, %{$status}); };
		warn $@ if $@;
		generate_graphs($rrdfile{status},$host) unless $@;
	}

	if (keys %{$scoreboard}) {
		eval { $rrd->update($rrdfile{scoreboard}, %{$scoreboard}); };
		warn $@ if $@;
		generate_graphs($rrdfile{scoreboard},$host) unless $@;
	}

	if (keys %{$logs}) {
		if (!-f $rrdfile{logs}) {
			eval {
				$rrd->create($rrdfile{logs}, map {($_=>'DERIVE')} keys %{$logs}));
				RRDs::tune($rrdfile{logs},'-i',"$_:0") for
						$rrd->sources($rrdfile{logs});
			};
			warn $@ if $@;
		}

		eval { $rrd->update($rrdfile{logs}, map {($_=>$logs->{$_})} keys %{$logs})); };
		warn $@ if $@;
		generate_graphs($rrdfile{logs},$host) unless $@;
	}

	if (keys %{$modules}) {
		eval { $rrd->update($rrdfile{modules}, %{$modules}); };
		warn $@ if $@;
		generate_graphs($rrdfile{modules},$host) unless $@;
	}

	$VERBOSE && printf("[%6.2f]\n", Time::HiRes::time() - $start_time);
}



exit;



#####################################
# Subs init

sub loc_server {
	(split(/\./,$a))[1] cmp (split(/\./,$b))[1]
		||
	($a =~ /^mod_perl(\d+)/)[0] <=> ($b =~ /^mod_perl(\d+)/)[0]
}

sub generate_graphs {
	my ($rrdfile,$host) = @_;

	eval {
		if ($rrdfile =~ /status/) {
			$rrd->graph($rrdfile,
					basename => "$host-status-total",
					destination => IMGDIR,
					title => "$host Total x",
					vertical_label => 'Total x',
					sources => [ grep(/Total|Uptime/i,$rrd->sources($rrdfile)) ],
					line_thickness => 2,
				);
			$rrd->graph($rrdfile,
					basename => "$host-status-bytes2",
					destination => IMGDIR,
					title => "$host x/Sec",
					vertical_label => 'x/Sec',
					sources => [ grep(/KBPerSec|ReqPerSec/i,$rrd->sources($rrdfile)) ],
					line_thickness => 2,
				);
			$rrd->graph($rrdfile,
					basename => "$host-status-bytes",
					destination => IMGDIR,
					title => "$host Bytes/x",
					vertical_label => 'Bytes/x',
					sources => [ grep(/BytesPerSec|BytesPerReq/i,$rrd->sources($rrdfile)) ],
					line_thickness => 2,
				);
			$rrd->graph($rrdfile,
					basename => "$host-status-servers",
					destination => IMGDIR,
					title => "$host Servers",
					vertical_label => 'Children + Load',
					sources => [ grep(/Servers|CPULoad/i,$rrd->sources($rrdfile)) ],
					line_thickness => 2,
				);

		} elsif ($rrdfile =~ /scoreboard/) {
			$rrd->graph($rrdfile,
					destination => IMGDIR,
					title => "$host Scoreboard",
					line_thickness => 2,
					vertical_label => 'Apache Children',
					source_colors => [ qw(
						FF0000 00FF00 0000FF FFFF00 00FFFF FF00FF 000000
						AA0000 00AA00 0000AA AAAA00 00AAAA AA00AA AAAAAA
						550000 005500 000055 555500 005555 550055 555555
					) ],
				);

		} elsif ($rrdfile =~ /modules/) {
			$rrd->graph($rrdfile,
					basename => "$host-modules",
					destination => IMGDIR,
					vertical_label => 'Resident Modules',
					title => "$host Modules",
					line_thickness => 2,
				);

		} elsif ($rrdfile =~ /logs/) {
			$rrd->graph($rrdfile,
					basename => "$host-logs",
					destination => IMGDIR,
					title => "$host Logging/Sec",
					line_thickness => 2,
					vertical_label => 'bytes/sec',
					sources => [ sort($rrd->sources($rrdfile)) ],
				);
		}
	};
	warn $@ if $@;
}

sub parse_statlogs {
	my ($ua,$url) = @_;
	my %logs = ();

	my $response = $ua->get($url);
	if ($response->is_success) {
		for (split(/\n+|\r+/,$response->content)) {
			my ($file,$size,$modified) = split(/\s+/,$_);
			$logs{$file} = $size;
		}
	}

	DUMP('parse_statlogs(): \%logs',\%logs);
	return \%logs;
}

sub parse_perl_status {
	my ($ua,$url) = @_;
	my %modules = map {($_=>0)} qw(usr_lib other);

	my $response = $ua->get($url);
	if ($response->is_success) {
		for (split(/\n+|\r+/,$response->content)) {
			if (my ($module,$file) = $_ =~
					m,^<tr><td><a href="/perl-status\?(.+?)".+</td><td>(.+?)</td></tr>\s*$,) {

				local $_ = $file;
				if (m,^/usr/,) {
					$modules{usr_lib}++;
				} else {
					$modules{other}++;
				}
			}
		}
	}

	DUMP('parse_perl_status(): \%modules',\%modules);
	return \%modules;
}

sub parse_apache_status {
	my ($ua,$url) = @_;
	my %scoreboard = ();
	my %status = ();

	my %keys = (W => 'Write', G => 'GraceClose', D => 'DNS', S => 'Starting',
		L => 'Logging', R => 'Read', K => 'Keepalive', C => 'Closing',
		I => 'Idle', '_' => 'Waiting');

	my $response = $ua->get($url);
	if ($response->is_success) {
		for (split(/\n+|\r+/,$response->content)) {
			my ($k,$v) = $_ =~ /^\s*(.+?):\s+(.+?)\s*$/;
			$k =~ s/\s+//g; #$k = lc($k);
			if ($k eq 'Scoreboard') {
				my %x; $x{$_}++ for split(//,$v);
				%scoreboard = ( map { ($keys{$_}, $x{$_}) } keys %keys );
			} else {
				$status{$k} = $v;
			}
		}
	} else {
		TRACE("parse_apache_status(): failed to get $url; ".$response->status_line);
	}

	DUMP('parse_apache_status(): \%scoreboard',\%scoreboard);
	DUMP('parse_apache_status(): \%status',\%status);
	return (\%status,\%scoreboard);
}

sub user_agent {
	my $ua = LWP::UserAgent->new(
			agent => "RRD::Simple example $0 $VERSION",
			timeout => TIMEOUT,
		);
	$ua->env_proxy;
	$ua->max_size(1024*250);
	return $ua;
}

sub ip2host {
	my $ip = shift;
	my @numbers = split(/\./, $ip);
	my $ip_number = pack("C4", @numbers);
	my ($host) = (gethostbyaddr($ip_number, 2))[0];
	if (defined $host && $host) {
		return $host;
	} else {
		return $ip;
	}
}

sub TRACE {
	return unless $DEBUG;
	warn(shift());
}

sub DUMP {
	return unless $DEBUG;
	eval {
		require Data::Dumper;
		warn(shift().': '.Data::Dumper::Dumper(shift()));
	}
}


1;


__END__