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 => '/var/www/rrd'; |
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 |
table => \&table, |
319 |
like => sub { return defined($_[0]) && defined($_[1]) && $_[0] =~ /$_[1]/i ? 1 : 0; }, |
320 |
not => sub { return !$_[0]; }, |
321 |
equal_or_like => sub { |
322 |
return 1 if (!defined($_[1]) || !length($_[1])) && (!defined($_[2]) || !length($_[2])); |
323 |
#(warn "$_[0] eq $_[1]\n" && return 1) if defined $_[1] && "$_[0]" eq "$_[1]"; |
324 |
(return 1) if defined $_[1] && "$_[0]" eq "$_[1]"; |
325 |
return 1 if defined $_[2] && "$_[0]" =~ /$_[2]/; |
326 |
return 0; |
327 |
}, |
328 |
}, |
329 |
); |
330 |
$template->param(\%tmpl); |
331 |
|
332 |
$html->{html} = $template->output(); |
333 |
$html->{html} =~ s/[ \t][ \t]+/ /g unless $q{DEBUG}; |
334 |
$html->{last_update} = time; |
335 |
eval { $CACHE->freeze($cache_key, $html); }; |
336 |
warn $@ if $@; |
337 |
print $cgi->header(-content => 'text/html'), $html->{html}; |
338 |
|
339 |
exit; |
340 |
|
341 |
|
342 |
# Is the RRD file that generated this image considered stale? |
343 |
sub stale_rrd { |
344 |
my $rrd_file = shift; |
345 |
return unless defined $rrd_file && $rrd_file; |
346 |
my $rrd_mtime = (stat($rrd_file))[9]; |
347 |
|
348 |
if (defined(wantarray)) { |
349 |
my $modified = scalar(localtime($rrd_mtime)); |
350 |
if (wantarray) { |
351 |
return (1, $modified) if time - $rrd_mtime >= STALE_THRESHOLD; |
352 |
return (0, $modified); |
353 |
} else { |
354 |
return 1 if time - $rrd_mtime >= STALE_THRESHOLD; |
355 |
return 0; |
356 |
} |
357 |
} |
358 |
|
359 |
return; |
360 |
} |
361 |
|
362 |
# Slurp in a file from disk, yum yum |
363 |
sub slurp { |
364 |
my $rtn = $_[0]; |
365 |
if (open(FH,'<',$_[0])) { |
366 |
local $/ = undef; |
367 |
$rtn = <FH>; |
368 |
close(FH); |
369 |
} |
370 |
return $rtn; |
371 |
} |
372 |
|
373 |
sub table { |
374 |
my $file = shift; |
375 |
my @rows = split(/[\n\r]+/, slurp($file)); |
376 |
use Data::Dump qw/dump/; |
377 |
warn dump( @rows ); |
378 |
return |
379 |
qq|<tr><th colspan=4>| . shift(@rows) . qq|</th><tr>| |
380 |
. qq|<tr><th></th><th>min</th><th>max</th><th>last</th></tr>| |
381 |
. join("\n", map { |
382 |
qq|<tr><td>| |
383 |
. join(qq|</td><td align=right>|, split(/,?\s+\w+:\s+/, $_)) |
384 |
. qq|</tr><td>| |
385 |
} @rows |
386 |
) |
387 |
; |
388 |
} |
389 |
|
390 |
# Sort by domain |
391 |
sub by_domain { |
392 |
sub split_domain { |
393 |
local $_ = shift || ''; |
394 |
if (/(.*)\.(\w\w\w+)$/) { |
395 |
return ($2,$1); |
396 |
} elsif (/(.*)\.(\w+\.\w\w)$/) { |
397 |
return ($2,$1); |
398 |
} |
399 |
return ($_,''); |
400 |
} |
401 |
my @A = split_domain($a); |
402 |
my @B = split_domain($b); |
403 |
|
404 |
($A[0] cmp $B[0]) |
405 |
|| |
406 |
($A[1] cmp $B[1]) |
407 |
} |
408 |
|
409 |
# Sort by time period |
410 |
sub alpha_period { |
411 |
my %order = qw(daily 0 weekly 1 monthly 2 annual 3 3year 4); |
412 |
($a =~ /^(.+)\-/)[0] cmp ($b =~ /^(.+)\-/)[0] |
413 |
|| |
414 |
$order{($a =~ /^.+\-(\w+)\./)[0]} <=> $order{($b =~ /^.+\-(\w+)\./)[0]} |
415 |
} |
416 |
|
417 |
# Return a list of items in a directory |
418 |
sub list_dir { |
419 |
my $dir = shift; |
420 |
opendir(DH,$dir) || die "Unable to open file handle for directory '$dir': $!"; |
421 |
my @items = grep(!/^\./,readdir(DH)); |
422 |
closedir(DH) || die "Unable to close file handle for directory '$dir': $!"; |
423 |
return @items; |
424 |
} |
425 |
|
426 |
# Pull out the most relevent graph definition |
427 |
sub graph_def { |
428 |
my ($gdefs,$graph) = @_; |
429 |
return {} unless defined $graph; |
430 |
|
431 |
my $rtn = {}; |
432 |
for (keys %{$gdefs->{graph}}) { |
433 |
my $graph_key = qr(^$_$); |
434 |
if ($graph =~ /$graph_key/) { |
435 |
$rtn = { %{$gdefs->{graph}->{$_}} }; |
436 |
my ($var) = $graph =~ /_([^_]+)$/; |
437 |
for my $key (keys %{$rtn}) { |
438 |
$rtn->{$key} =~ s/\$1/$var/g; |
439 |
} |
440 |
last; |
441 |
} |
442 |
} |
443 |
|
444 |
return $rtn; |
445 |
} |
446 |
|
447 |
# Read in the graph definition config file |
448 |
sub read_graph_data { |
449 |
my $filename = shift || undef; |
450 |
|
451 |
my %config = (); |
452 |
eval { |
453 |
my $conf = new Config::General( |
454 |
-ConfigFile => $filename, |
455 |
-LowerCaseNames => 1, |
456 |
-UseApacheInclude => 1, |
457 |
-IncludeRelative => 1, |
458 |
# -DefaultConfig => \%default, |
459 |
-MergeDuplicateBlocks => 1, |
460 |
-AllowMultiOptions => 1, |
461 |
-MergeDuplicateOptions => 1, |
462 |
-AutoTrue => 1, |
463 |
); |
464 |
%config = $conf->getall; |
465 |
}; |
466 |
warn $@ if $@; |
467 |
|
468 |
return \%config; |
469 |
} |
470 |
|
471 |
1; |
472 |
|
473 |
|