| 1 |
#!/usr/bin/perl |
| 2 |
############################################################ |
| 3 |
# |
| 4 |
# $Id: rrd-browse.cgi 692 2006-06-26 19:11:14Z nicolaw $ |
| 5 |
# rrd-browse.cgi - Graph browser CGI script for RRD::Simple |
| 6 |
# |
| 7 |
# Copyright 2006,2007 Nicola Worthington |
| 8 |
# |
| 9 |
# Licensed under the Apache License, Version 2.0 (the "License"); |
| 10 |
# you may not use this file except in compliance with the License. |
| 11 |
# You may obtain a copy of the License at |
| 12 |
# |
| 13 |
# http://www.apache.org/licenses/LICENSE-2.0 |
| 14 |
# |
| 15 |
# Unless required by applicable law or agreed to in writing, software |
| 16 |
# distributed under the License is distributed on an "AS IS" BASIS, |
| 17 |
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. |
| 18 |
# See the License for the specific language governing permissions and |
| 19 |
# limitations under the License. |
| 20 |
# |
| 21 |
############################################################ |
| 22 |
# vim:ts=4:sw=4:tw=78 |
| 23 |
|
| 24 |
# User defined constants |
| 25 |
use constant BASEDIR => '/home/nicolaw/webroot/www/rrd.me.uk'; |
| 26 |
use constant RRDURL => ''; |
| 27 |
|
| 28 |
# Caching |
| 29 |
use constant CACHE => 1; |
| 30 |
use constant DEFAULT_EXPIRES => '60 minutes'; |
| 31 |
|
| 32 |
# When is an RRD file regarded as stale? |
| 33 |
use constant STALE_THRESHOLD => 60*60; # 60 minutes |
| 34 |
|
| 35 |
############################################################ |
| 36 |
|
| 37 |
|
| 38 |
|
| 39 |
|
| 40 |
use 5.6.1; |
| 41 |
use warnings; |
| 42 |
use strict; |
| 43 |
use CGI; |
| 44 |
use CGI::Carp qw(fatalsToBrowser); |
| 45 |
use HTML::Template::Expr; |
| 46 |
use File::Basename qw(basename); |
| 47 |
use Config::General qw(); |
| 48 |
use File::Spec::Functions qw(tmpdir catdir catfile); |
| 49 |
use vars qw(%LIST_CACHE %GRAPH_CACHE %SLURP_CACHE |
| 50 |
$CACHE_ROOT $CACHE $FRESHEN_CACHE %STALERRD_CACHE); |
| 51 |
|
| 52 |
# Enable some basic caching. |
| 53 |
# See notes about $tmpl_cache a little further |
| 54 |
# down in this code. |
| 55 |
if (CACHE) { |
| 56 |
# Cache calls to list_dir() and graph_def() |
| 57 |
require Memoize; |
| 58 |
Memoize::memoize('list_dir', LIST_CACHE => [HASH => \%LIST_CACHE]); |
| 59 |
Memoize::memoize('graph_def', SCALAR_CACHE => [HASH => \%GRAPH_CACHE]); |
| 60 |
Memoize::memoize('stale_rrd', SCALAR_CACHE => [HASH => \%STALERRD_CACHE]); |
| 61 |
|
| 62 |
# This isn't really necessary unless you're viewing the same page many |
| 63 |
# times over in defail view - i don't think that the extra memory utilisation |
| 64 |
# is worth the small improvement in rendering time. |
| 65 |
#Memoize::memoize('slurp', SCALAR_CACHE => [HASH => \%SLURP_CACHE]); |
| 66 |
|
| 67 |
# Try some caching on disk |
| 68 |
unless (defined($CACHE) && ref($CACHE)) { |
| 69 |
$CACHE_ROOT = catdir(tmpdir(), 'rrd-browse.cgi'); |
| 70 |
mkdir($CACHE_ROOT,0700) unless -d $CACHE_ROOT; |
| 71 |
eval { |
| 72 |
require Cache::File; |
| 73 |
$CACHE = Cache::File->new( |
| 74 |
cache_root => $CACHE_ROOT, |
| 75 |
default_expires => DEFAULT_EXPIRES |
| 76 |
); |
| 77 |
}; |
| 78 |
warn $@ if $@; |
| 79 |
}; |
| 80 |
} |
| 81 |
|
| 82 |
|
| 83 |
# Grab CGI paramaters |
| 84 |
my $cgi = new CGI; |
| 85 |
my %q = $cgi->Vars; |
| 86 |
my $cache_key = $cgi->self_url(-absolute => 1, -query_string => 1, -path_info => 1); |
| 87 |
|
| 88 |
# cd to the righr location and define directories |
| 89 |
my %dir = map { ( $_ => BASEDIR."/$_" ) } qw(data etc graphs cgi-bin thumbnails); |
| 90 |
chdir $dir{'cgi-bin'} || die sprintf("Unable to chdir to '%s': %s", $dir{'cgi-bin'}, $!); |
| 91 |
|
| 92 |
# Create the initial %tmpl data hash |
| 93 |
my %tmpl = %ENV; |
| 94 |
$tmpl{template} = defined $q{template} && -f $q{template} ? $q{template} : 'index.tmpl'; |
| 95 |
die "Uh uh uh! Who's a naughty boy?\n" if $tmpl{template} =~ /^\s*\// || $tmpl{template} =~ /\.\./ || $tmpl{template} !~ /\.tmpl$/i; |
| 96 |
$tmpl{PERIOD} = defined $q{PERIOD} && $q{PERIOD} =~ /^(daily|weekly|monthly|annual)$/i ? lc($q{PERIOD}) : 'daily'; |
| 97 |
$tmpl{title} = ucfirst(basename($tmpl{template},'.tmpl')); $tmpl{title} =~ s/[_\-]/ /g; |
| 98 |
$tmpl{self_url} = $cgi->self_url(-absolute => 1, -query_string => 0, -path_info => 0); |
| 99 |
$tmpl{rrd_url} = RRDURL; |
| 100 |
|
| 101 |
# Go read a bunch of stuff from disk to pump in to %tmpl in a moment |
| 102 |
my $gdefs = read_graph_data("$dir{etc}/graph.defs"); |
| 103 |
my @graphs = list_dir($dir{graphs}); |
| 104 |
# my @thumbnails = list_dir($dir{thumbnails}); # Not used anywhere |
| 105 |
|
| 106 |
|
| 107 |
# Build up the data in %tmpl by host |
| 108 |
# The $tmpl_cache structure could be cached in theory, but |
| 109 |
# the process of thawing actually uses LOTS of memory if |
| 110 |
# the source structure was quite sizable to start with. For |
| 111 |
# this reason, I'm *NOT* actually caching this structure |
| 112 |
# anymore, and am opting to cache the HTML output on a per |
| 113 |
# URL basis. This means there's less chance of a cache hit, |
| 114 |
# but it means you don't use 715MB of memory if you have |
| 115 |
# 100 or so servers with an average of 25 graphs per host. |
| 116 |
my $tmpl_cache = { |
| 117 |
graph_tmpl => {}, |
| 118 |
hosts => [], |
| 119 |
graphs => [], |
| 120 |
}; |
| 121 |
|
| 122 |
|
| 123 |
# Pull in the HTML cache (mentioned above) |
| 124 |
my $html = { last_update => 0, html => '' }; |
| 125 |
|
| 126 |
# Check if we should force an update on the cache |
| 127 |
if ($q{FRESHEN_CACHE}) { |
| 128 |
$FRESHEN_CACHE = 1 ; |
| 129 |
} |
| 130 |
|
| 131 |
# Check the mtimes of each directory for any modifications |
| 132 |
# and thereby a requirement to freshen our caches |
| 133 |
if (!defined($FRESHEN_CACHE) && !$FRESHEN_CACHE) { |
| 134 |
while (my ($k,$dir) = each %dir) { |
| 135 |
if (!defined $html->{last_update} || (stat($dir))[9] > $html->{last_update}) { |
| 136 |
$FRESHEN_CACHE = 1; |
| 137 |
warn "$k($dir) has been modified since the cache was last updated; forcing an update now\n"; |
| 138 |
} |
| 139 |
} |
| 140 |
} |
| 141 |
|
| 142 |
# Output from the cache if possible |
| 143 |
if (!$FRESHEN_CACHE) { |
| 144 |
eval { $html = $CACHE->thaw($cache_key); }; |
| 145 |
warn $@ if $@; |
| 146 |
if ($html->{html}) { |
| 147 |
#warn "Using cached version '$cache_key'\n"; |
| 148 |
$html->{html} =~ s/[ \t][ \t]+/ /g unless $q{DEBUG}; |
| 149 |
print $cgi->header(-content => 'text/html'), $html->{html}; |
| 150 |
exit; |
| 151 |
} |
| 152 |
} else { |
| 153 |
%LIST_CACHE = (); |
| 154 |
%GRAPH_CACHE = (); |
| 155 |
%STALERRD_CACHE = (); |
| 156 |
%SLURP_CACHE = (); |
| 157 |
} |
| 158 |
|
| 159 |
|
| 160 |
####################################### |
| 161 |
# |
| 162 |
# This section of code is REALLY slow and |
| 163 |
# ineffecient. A basic work around of caching |
| 164 |
# pages based on the URL has been implemented |
| 165 |
# to try and avoid having to execute this code |
| 166 |
# at all. This is a poor work around. I need |
| 167 |
# to optimise this code. If you have any |
| 168 |
# patches to help, please send them to |
| 169 |
# nicolaw@cpan.org. |
| 170 |
# |
| 171 |
####################################### |
| 172 |
for my $host (sort by_domain list_dir($dir{data})) { |
| 173 |
my $path = catfile($dir{data},$host); |
| 174 |
next unless -d $path || (-l $path && -d readlink($path)); |
| 175 |
|
| 176 |
# NEECHI-HACK! |
| 177 |
# This is removing some templating logic from the HTML::Template .tmpl file |
| 178 |
# themsevles and bringing it in to this loop in order to save a number of |
| 179 |
# loop cycles and speed up the pre-processing before we render the HTML. |
| 180 |
next if defined($q{HOST}) && $q{HOST} ne $host; |
| 181 |
next if defined($q{LIKE}) && $tmpl{template} =~ /^by_host\.[^\.]+$/i && $host !~ /$q{LIKE}/i; |
| 182 |
|
| 183 |
(my $node = $host) =~ s/\..*//; |
| 184 |
(my $domain = $host) =~ s/^.*?\.//; |
| 185 |
(my $domain2 = $domain) =~ s/[^a-zA-Z0-9\_]/_/g; |
| 186 |
(my $host2 = $host) =~ s/[^a-zA-Z0-9\_]/_/g; |
| 187 |
|
| 188 |
my %host = ( |
| 189 |
host => $host, |
| 190 |
host2 => $host2, |
| 191 |
node => $node, |
| 192 |
domain => $domain, |
| 193 |
domain2 => $domain2, |
| 194 |
); |
| 195 |
|
| 196 |
# Build a hash of potential files that users can slurp() or include |
| 197 |
# in their output template on a per host basis. |
| 198 |
for my $file (grep(/\.(?:te?xt|s?html?|xslt?|xml|css|tmpl)$/i, |
| 199 |
glob("$dir{data}/$host/include*.*"))) { |
| 200 |
(my $base = basename($file)) =~ s/\./_/g; |
| 201 |
$host{$base} = $file; |
| 202 |
} |
| 203 |
|
| 204 |
if (!grep(/^$host$/,@graphs)) { |
| 205 |
$host{no_graphs} = 1; |
| 206 |
push @{$tmpl_cache->{hosts}}, \%host; |
| 207 |
|
| 208 |
} else { |
| 209 |
my $all_host_rrds_stale = 1; |
| 210 |
|
| 211 |
for (qw(thumbnails graphs)) { |
| 212 |
eval { |
| 213 |
my @ary = (); |
| 214 |
for my $img (sort alpha_period |
| 215 |
grep(/\.(png|jpe?g|gif)$/i,list_dir("$dir{$_}/$host"))) { |
| 216 |
my ($graph) = ($img =~ /^(.+)\-\w+\.\w+$/); |
| 217 |
|
| 218 |
# NEECHI-HACK! |
| 219 |
# This is another nasty hack that removed some of the logic from the |
| 220 |
# HTML::Template code by pre-excluding specific data from the template |
| 221 |
# data and thereby speeding up the rendering of the HTML. |
| 222 |
next if defined($q{GRAPH}) && $q{GRAPH} ne $graph; |
| 223 |
next if defined($q{LIKE}) |
| 224 |
&& $tmpl{template} =~ /^by_graph\.[^\.]+$/i |
| 225 |
&& $graph !~ /$q{LIKE}/i; |
| 226 |
|
| 227 |
my %hash = ( |
| 228 |
src => "$tmpl{rrd_url}/$_/$host/$img", |
| 229 |
period => ($img =~ /.*-(\w+)\.\w+$/), |
| 230 |
graph => $graph, |
| 231 |
); |
| 232 |
|
| 233 |
my $gdef = graph_def($gdefs,$hash{graph}); |
| 234 |
$hash{title} = defined $gdef->{title} ? $gdef->{title} : $hash{graph}; |
| 235 |
|
| 236 |
# Is the RRD file that generated this image considered stale? |
| 237 |
my ($stale, $last_modified) = stale_rrd(catfile($dir{data},$host,"$graph.rrd")); |
| 238 |
if (defined($stale) && $stale) { |
| 239 |
$hash{stale} = $last_modified; |
| 240 |
} else { |
| 241 |
$all_host_rrds_stale = 0; |
| 242 |
} |
| 243 |
|
| 244 |
# Include the path on disk to the .txt file that is generated by the |
| 245 |
# output of the RRD::Simple->graph() method while generating the graphs |
| 246 |
$hash{txt} = catfile($dir{graphs},$host,"$img.txt") |
| 247 |
if $_ eq 'graphs' |
| 248 |
&& -e catfile($dir{graphs},$host,"$img.txt") |
| 249 |
&& (stat(_))[7] > 5; |
| 250 |
|
| 251 |
push @ary, \%hash; |
| 252 |
|
| 253 |
# By graph later |
| 254 |
if ($_ eq 'thumbnails' && defined $hash{graph}) { |
| 255 |
# && defined $hash{period} && $hash{period} eq 'daily') { |
| 256 |
my %hash2 = %hash; |
| 257 |
delete $hash2{title}; |
| 258 |
$hash2{host} = $host; |
| 259 |
if (defined $hash{period} && $hash{period} eq 'daily') { |
| 260 |
$tmpl_cache->{hosts_per_graph}->{$hash{graph}} = 0 |
| 261 |
unless defined $tmpl_cache->{hosts_per_graph}->{$hash{graph}}; |
| 262 |
$tmpl_cache->{hosts_per_graph}->{$hash{graph}}++; |
| 263 |
} |
| 264 |
push @{$tmpl_cache->{graph_tmpl}->{"$hash{graph}\t$hash{title}"}}, \%hash2; |
| 265 |
} |
| 266 |
} |
| 267 |
$host{$_} = \@ary; |
| 268 |
}; |
| 269 |
warn $@ if $@; |
| 270 |
} |
| 271 |
|
| 272 |
if ($all_host_rrds_stale) { |
| 273 |
$host{stale} = 1; |
| 274 |
} |
| 275 |
$host{total_graphs} = grep(/^daily$/, map { $_->{period} } @{$host{graphs}}); |
| 276 |
push @{$tmpl_cache->{hosts}}, \%host; |
| 277 |
} |
| 278 |
} |
| 279 |
|
| 280 |
# Merge cache data in |
| 281 |
$tmpl{hosts} = $tmpl_cache->{hosts}; |
| 282 |
|
| 283 |
# Merge by-graph cache data in |
| 284 |
for (sort keys %{$tmpl_cache->{graph_tmpl}}) { |
| 285 |
my ($graph,$title) = split(/\t/,$_); |
| 286 |
push @{$tmpl{graphs}}, { |
| 287 |
graph => $graph, |
| 288 |
graph_title => $title, |
| 289 |
total_hosts => $tmpl_cache->{hosts_per_graph}->{$graph}, |
| 290 |
thumbnails => $tmpl_cache->{graph_tmpl}->{$_}, |
| 291 |
}; |
| 292 |
} |
| 293 |
|
| 294 |
# Render the output |
| 295 |
if (exists $q{DEBUG} && $q{DEBUG} eq 'insecure') { |
| 296 |
require Data::Dumper; |
| 297 |
$tmpl{DEBUG} = Data::Dumper::Dumper(\%tmpl); |
| 298 |
} |
| 299 |
my $template = HTML::Template::Expr->new( |
| 300 |
filename => $tmpl{template}, |
| 301 |
|
| 302 |
# This caching doesn't work properly with |
| 303 |
# HTML::Template::Expr |
| 304 |
#cache => 1, |
| 305 |
#shared_cache => 1, |
| 306 |
#file_cache => 1, |
| 307 |
#file_cache_dir => $CACHE_ROOT, |
| 308 |
#file_cache_dir_mode => 0700, |
| 309 |
|
| 310 |
associate => $cgi, |
| 311 |
case_sensitive => 1, |
| 312 |
loop_context_vars => 1, |
| 313 |
max_includes => 5, |
| 314 |
global_vars => 1, |
| 315 |
die_on_bad_params => 0, |
| 316 |
functions => { |
| 317 |
slurp => \&slurp, |
| 318 |
like => sub { return defined($_[0]) && defined($_[1]) && $_[0] =~ /$_[1]/i ? 1 : 0; }, |
| 319 |
not => sub { return !$_[0]; }, |
| 320 |
equal_or_like => sub { |
| 321 |
return 1 if (!defined($_[1]) || !length($_[1])) && (!defined($_[2]) || !length($_[2])); |
| 322 |
#(warn "$_[0] eq $_[1]\n" && return 1) if defined $_[1] && "$_[0]" eq "$_[1]"; |
| 323 |
(return 1) if defined $_[1] && "$_[0]" eq "$_[1]"; |
| 324 |
return 1 if defined $_[2] && "$_[0]" =~ /$_[2]/; |
| 325 |
return 0; |
| 326 |
}, |
| 327 |
}, |
| 328 |
); |
| 329 |
$template->param(\%tmpl); |
| 330 |
|
| 331 |
$html->{html} = $template->output(); |
| 332 |
$html->{html} =~ s/[ \t][ \t]+/ /g unless $q{DEBUG}; |
| 333 |
$html->{last_update} = time; |
| 334 |
eval { $CACHE->freeze($cache_key, $html); }; |
| 335 |
warn $@ if $@; |
| 336 |
print $cgi->header(-content => 'text/html'), $html->{html}; |
| 337 |
|
| 338 |
exit; |
| 339 |
|
| 340 |
|
| 341 |
# Is the RRD file that generated this image considered stale? |
| 342 |
sub stale_rrd { |
| 343 |
my $rrd_file = shift; |
| 344 |
return unless defined $rrd_file && $rrd_file; |
| 345 |
my $rrd_mtime = (stat($rrd_file))[9]; |
| 346 |
|
| 347 |
if (defined(wantarray)) { |
| 348 |
my $modified = scalar(localtime($rrd_mtime)); |
| 349 |
if (wantarray) { |
| 350 |
return (1, $modified) if time - $rrd_mtime >= STALE_THRESHOLD; |
| 351 |
return (0, $modified); |
| 352 |
} else { |
| 353 |
return 1 if time - $rrd_mtime >= STALE_THRESHOLD; |
| 354 |
return 0; |
| 355 |
} |
| 356 |
} |
| 357 |
|
| 358 |
return; |
| 359 |
} |
| 360 |
|
| 361 |
# Slurp in a file from disk, yum yum |
| 362 |
sub slurp { |
| 363 |
my $rtn = $_[0]; |
| 364 |
if (open(FH,'<',$_[0])) { |
| 365 |
local $/ = undef; |
| 366 |
$rtn = <FH>; |
| 367 |
close(FH); |
| 368 |
} |
| 369 |
return $rtn; |
| 370 |
} |
| 371 |
|
| 372 |
# Sort by domain |
| 373 |
sub by_domain { |
| 374 |
sub split_domain { |
| 375 |
local $_ = shift || ''; |
| 376 |
if (/(.*)\.(\w\w\w+)$/) { |
| 377 |
return ($2,$1); |
| 378 |
} elsif (/(.*)\.(\w+\.\w\w)$/) { |
| 379 |
return ($2,$1); |
| 380 |
} |
| 381 |
return ($_,''); |
| 382 |
} |
| 383 |
my @A = split_domain($a); |
| 384 |
my @B = split_domain($b); |
| 385 |
|
| 386 |
($A[0] cmp $B[0]) |
| 387 |
|| |
| 388 |
($A[1] cmp $B[1]) |
| 389 |
} |
| 390 |
|
| 391 |
# Sort by time period |
| 392 |
sub alpha_period { |
| 393 |
my %order = qw(daily 0 weekly 1 monthly 2 annual 3 3year 4); |
| 394 |
($a =~ /^(.+)\-/)[0] cmp ($b =~ /^(.+)\-/)[0] |
| 395 |
|| |
| 396 |
$order{($a =~ /^.+\-(\w+)\./)[0]} <=> $order{($b =~ /^.+\-(\w+)\./)[0]} |
| 397 |
} |
| 398 |
|
| 399 |
# Return a list of items in a directory |
| 400 |
sub list_dir { |
| 401 |
my $dir = shift; |
| 402 |
opendir(DH,$dir) || die "Unable to open file handle for directory '$dir': $!"; |
| 403 |
my @items = grep(!/^\./,readdir(DH)); |
| 404 |
closedir(DH) || die "Unable to close file handle for directory '$dir': $!"; |
| 405 |
return @items; |
| 406 |
} |
| 407 |
|
| 408 |
# Pull out the most relevent graph definition |
| 409 |
sub graph_def { |
| 410 |
my ($gdefs,$graph) = @_; |
| 411 |
return {} unless defined $graph; |
| 412 |
|
| 413 |
my $rtn = {}; |
| 414 |
for (keys %{$gdefs->{graph}}) { |
| 415 |
my $graph_key = qr(^$_$); |
| 416 |
if ($graph =~ /$graph_key/) { |
| 417 |
$rtn = { %{$gdefs->{graph}->{$_}} }; |
| 418 |
my ($var) = $graph =~ /_([^_]+)$/; |
| 419 |
for my $key (keys %{$rtn}) { |
| 420 |
$rtn->{$key} =~ s/\$1/$var/g; |
| 421 |
} |
| 422 |
last; |
| 423 |
} |
| 424 |
} |
| 425 |
|
| 426 |
return $rtn; |
| 427 |
} |
| 428 |
|
| 429 |
# Read in the graph definition config file |
| 430 |
sub read_graph_data { |
| 431 |
my $filename = shift || undef; |
| 432 |
|
| 433 |
my %config = (); |
| 434 |
eval { |
| 435 |
my $conf = new Config::General( |
| 436 |
-ConfigFile => $filename, |
| 437 |
-LowerCaseNames => 1, |
| 438 |
-UseApacheInclude => 1, |
| 439 |
-IncludeRelative => 1, |
| 440 |
# -DefaultConfig => \%default, |
| 441 |
-MergeDuplicateBlocks => 1, |
| 442 |
-AllowMultiOptions => 1, |
| 443 |
-MergeDuplicateOptions => 1, |
| 444 |
-AutoTrue => 1, |
| 445 |
); |
| 446 |
%config = $conf->getall; |
| 447 |
}; |
| 448 |
warn $@ if $@; |
| 449 |
|
| 450 |
return \%config; |
| 451 |
} |
| 452 |
|
| 453 |
1; |
| 454 |
|
| 455 |
|
Parent Directory
| 
Revision Log