root/lib/Resmon/Status.pm

Revision b4a01ee848c6689e508db6c683e95fd59cb17f28, 16.6 kB (checked in by Mark Harrison <mark@omniti.com>, 4 years ago)

Changes to how modules are loaded:

Each module is an object inheriting from Resmon::Module as before, but the
code to support coderefs and raw packages with a handler function is all gone.
In addition, a lot of redundant code was removed, and some small changes made
to the modules themselves:

  • The check name is stored in $self->{check_name} (instead of
    $self->{object} as in the past)
  • The check configuration is stored in $self->{config} and not just as
    instance variables.
  • All modules must have fully qualified names in the config file. In other
    words - Resmon::Module::Resmon instead of just RESMON. In keeping with
    other perl module names, I've gone with Title Case instead of ALL CAPS
    for the sample module (Resmon). This is simple to change back if desired
    however.

git-svn-id: https://labs.omniti.com/resmon/branches/resmon2@268 8c0face9-b7db-6ec6-c4b3-d5f7145c7d55

  • Property mode set to 100644
Line 
1 package Resmon::Status;
2
3 use strict;
4 use POSIX qw/:sys_wait_h/;
5 use IO::Handle;
6 use IO::File;
7 use IO::Socket;
8 use Socket;
9 use Fcntl qw/:flock/;
10 use IPC::SysV qw /IPC_PRIVATE IPC_CREAT IPC_RMID S_IRWXU S_IRWXG S_IRWXO/;
11 use Data::Dumper;
12
13 my $SEGSIZE = 1024*256;
14 my $KEEPALIVE_TIMEOUT = 5;
15 my $REQUEST_TIMEOUT = 60;
16 sub new {
17     my $class = shift;
18     my $file = shift;
19     return bless {
20         file => $file
21     }, $class;
22 }
23 sub get_shared_state {
24     my $self = shift;
25     my $blob;
26     my $len;
27     return unless(defined($self->{shared_state}));
28     # Lock shared segment
29     # Read in
30     shmread($self->{shared_state}, $len, 0, length(pack('i', 0)));
31     $len = unpack('i', $len);
32     shmread($self->{shared_state}, $blob, length(pack('i', 0)), $len);
33     # unlock
34     my $VAR1;
35     eval $blob;
36     die $@ if ($@);
37     $self->{store} = $VAR1;
38     return $self->{store};
39 }
40 sub store_shared_state {
41     my $self = shift;
42     return unless(defined($self->{shared_state}));
43     my $blob = Dumper($self->{store});
44
45     # Lock shared segment
46     # Write state and flush
47     shmwrite($self->{shared_state}, pack('i', length($blob)),
48         0, length(pack('i', 0))) || die "$!";
49     shmwrite($self->{shared_state}, $blob, length(pack('i', 0)),
50         length($blob)) || die "$!";
51     # unlock
52 }
53 sub xml_kv_dump {
54     my $info = shift;
55     my $indent = shift || 0;
56     my $rv = '';
57     while(my ($key, $value) = each %$info) {
58         if(ref $value eq 'HASH') {
59             while (my ($k, $v) = each %$value) {
60                 $rv .= " " x $indent;
61                 $rv .= "<$key name=\"$k\"";
62                 if (ref($v) eq 'ARRAY') {
63                     # A value/type pair
64                     my $type = $v->[1];
65                     if ($type !~ /^[0iIlLns]$/) {
66                         $type = "0";
67                     }
68                     $rv .= " type=\"$type\"";
69                     $v = $v->[0];
70                 }
71                 $v = xml_escape($v);
72                 $rv .= ">$v</$key>\n";
73             }
74         } else {
75             $rv .= " " x $indent;
76             $value = xml_escape($value);
77             $rv .= "<$key>$value</$key>\n";
78         }
79     }
80     return $rv;
81 }
82 sub xml_info {
83     my ($module, $service, $info) = @_;
84     my $rv = '';
85     $rv .= "  <ResmonResult module=\"$module\" service=\"$service\">\n";
86     $rv .= xml_kv_dump($info, 4);
87     $rv .= "  </ResmonResult>\n";
88     return $rv;
89 }
90 sub xml_escape {
91     my $v = shift;
92     $v =~ s/&/&amp;/g;
93     $v =~ s/</&lt;/g;
94     $v =~ s/>/&gt;/g;
95     $v =~ s/'/&apos;/g;
96     return $v;
97 }
98 sub dump_generic {
99     my $self = shift;
100     my $dumper = shift;
101     my $rv = '';
102     while(my ($module, $services) = each %{$self->{store}}) {
103         while(my ($service, $info) = each %$services) {
104             $rv .= $dumper->($module,$service,$info);
105         }
106     }
107     return $rv;
108 }
109 sub dump_generic_module {
110     # Dumps a single module rather than all checks
111     my $self = shift;
112     my $dumper = shift;
113     my $module = shift;
114     my $rv = '';
115     my $services = $self->{store}->{$module};
116     while(my ($service, $info) = each %$services) {
117         $rv .= $dumper->($module,$service,$info);
118     }
119     return $rv;
120 }
121 sub dump_xml {
122     my $self = shift;
123     my $response = <<EOF
124 <?xml version="1.0" encoding="UTF-8"?>
125 <?xml-stylesheet type="text/xsl" href="/resmon.xsl"?>
126 <ResmonResults>
127 EOF
128     ;
129     $response .= $self->dump_generic(\&xml_info);
130     $response .= "</ResmonResults>\n";
131     return $response;
132 }
133 sub get_xsl() {
134     my $response = <<EOF
135 <?xml version="1.0" encoding="ISO-8859-1"?>
136 <xsl:stylesheet version="1.0"
137     xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
138 <xsl:template match="ResmonResults">
139 <html>
140 <head>
141     <title>Resmon Results</title>
142     <link rel="stylesheet" type="text/css" href="/resmon.css" />
143 </head>
144 <body>
145     <p>
146     Total checks:
147     <xsl:value-of select="count(ResmonResult)" />
148     </p>
149     <xsl:for-each select="ResmonResult">
150         <xsl:sort select="\@module" />
151         <xsl:sort select="\@service" />
152         <div class="item">
153             <div class="info">
154                 Last check: <xsl:value-of select="last_runtime_seconds" />
155                 /
156                 Last updated: <xsl:value-of select="last_update" />
157             </div>
158             <h1>
159                 <a>
160                     <xsl:attribute name="href">
161                         /<xsl:value-of select="\@module" />
162                     </xsl:attribute>
163                     <xsl:value-of select="\@module" />
164                 </a>`<a>
165                     <xsl:attribute name="href">
166                         /<xsl:value-of select="\@module"
167                             />/<xsl:value-of select="\@service" />
168                     </xsl:attribute>
169                     <xsl:value-of select="\@service" />
170                 </a>
171             </h1>
172             <ul>
173                 <xsl:for-each select="metric">
174                     <xsl:sort select="\@name" />
175                     <li><xsl:value-of select="\@name" /> =
176                     <xsl:value-of select="." /></li>
177                 </xsl:for-each>
178             </ul>
179         </div>
180     </xsl:for-each>
181 </body>
182 </html>
183 </xsl:template>
184 </xsl:stylesheet>
185 EOF
186     ;
187     return $response;
188 }
189 sub get_css() {
190     my $response=<<EOF
191 body {
192     font-family: Verdana, Arial, helvetica, sans-serif;
193 }
194
195 h1 {
196     margin: 0;
197     font-size: 120%;
198 }
199
200 h2 {
201     margin: 0;
202     font-size: 110%;
203 }
204
205 .item {
206     border: 1px solid black;
207     border-left: 10px solid #999;
208     padding: 1em;
209     margin: 2em;
210     background-color: #eeeeee;
211 }
212
213 .info {
214     float: right;
215     font-size: 80%;
216     padding: 0;
217     margin: 0;
218 }
219
220 table {
221     border: 1px solid black;
222     background-color: #eeeeee;
223     border-collapse: collapse;
224     margin: 1em;
225     font-size: 80%;
226 }
227
228 th {
229     font-size: 100%;
230     font-weight: bold;
231     background-color: black;
232     color: white;
233 }
234
235 td {
236     padding-left: 1em;
237     padding-right: 1em;
238 }
239
240 a {
241     text-decoration: none;
242 }
243
244 a.metrics, a.metrics:visited {
245     color: black;
246 }
247
248 a.metrics table {
249     display: none;
250 }
251
252 a.metrics:hover table {
253     display: block;
254     position: relative;
255     top: 1em;
256     right: 1em;
257     max-width: 95%;
258     overflow: hidden;
259 }
260 EOF
261     ;
262     return $response;
263 }
264 sub service {
265     my $self = shift;
266     my ($client, $req, $proto, $snip, $authuser, $authpass) = @_;
267     my $state = $self->get_shared_state();
268     if ($self->{authuser} ne "" &&
269         ($authuser ne $self->{authuser} || $authpass ne $self->{authpass})) {
270         my $response = "<html><head><title>Password required</title></head>" .
271         "<body><h1>Password required</h1></body></html>";
272         $client->print(http_header(401, length($response), 'text/html', $snip,
273                 "WWW-Authenticate: Basic realm=\"Resmon\"\n"));
274         $client->print($response . "\r\n");
275         return;
276     } elsif($req eq '/') {
277         my $response .= $self->dump_xml();
278         $client->print(http_header(200, length($response), 'text/xml', $snip));
279         $client->print($response . "\r\n");
280         return;
281     } elsif($req eq '/resmon.xsl') {
282         my $response = $self->get_xsl();
283         $client->print(http_header(200, length($response), 'text/xml', $snip));
284         $client->print($response . "\r\n");
285         return;
286     } elsif($req eq '/resmon.css') {
287         my $response = $self->get_css();
288         $client->print(http_header(200, length($response), 'text/css', $snip));
289         $client->print($response . "\r\n");
290         return;
291     } elsif($req =~ /^\/([^\/]+)\/(.+)$/) {
292         if(exists($self->{store}->{$1}) &&
293             exists($self->{store}->{$1}->{$2})) {
294             my $info = $self->{store}->{$1}->{$2};
295             my $response = qq^<?xml version="1.0" encoding="UTF-8"?>\n^;
296             my $response .= qq^<?xml-stylesheet type="text/xsl" href="/resmon.xsl"?>^;
297             $response .= "<ResmonResults>\n".
298             xml_info($1,$2,$info).
299             "</ResmonResults>\n";
300             $client->print(http_header(200, length($response), 'text/xml', $snip));
301             $client->print( $response . "\r\n");
302             return;
303         }
304     } elsif($req =~ /^\/([^\/]+)$/) {
305         if(exists($self->{store}->{$1})) {
306             my $response = qq^<?xml version="1.0" encoding="UTF-8"?>\n^;
307             my $response .= qq^<?xml-stylesheet type="text/xsl" href="/resmon.xsl"?>^;
308             $response .= "<ResmonResults>\n".
309             $self->dump_generic_module(\&xml_info,$1) .
310             "</ResmonResults>\n";
311             $client->print(http_header(200, length($response), 'text/xml', $snip));
312             $client->print( $response . "\r\n");
313             return;
314         }
315     }
316     die "Request not understood\n";
317 }
318 sub http_header {
319     my $code = shift;
320     my $len = shift;
321     my $type = shift || 'text/xml';
322     my $close_connection = shift || 1;
323     my $extra_headers = shift;
324     return "HTTP/1.0 $code OK\nServer: resmon\n" .
325         (defined($len) ? "Content-length: $len\n" : "") .
326     (($close_connection || !$len) ? "Connection: close\n" : "") .
327     "Content-Type: $type; charset=utf-8\n" . $extra_headers . "\n";
328 }
329 sub base64_decode($) {
330     # Base64 decoding for basic auth
331     # We cheat when doing the decoding - perl can do uudecoding using unpack -
332     # so we just convert to uuencoded text and decode that.
333     my $enc = shift;
334     if (length($enc) % 4 != 0) { return "" } # Length should be multiple of 4
335     $enc =~ tr#A-Za-z0-9+/=##cd; # Ignore any invalid characters
336     $enc =~ tr#A-Za-z0-9+/=# -_#d; # Convert base64 to uuencode alphabet and
337     # strip padding
338     if (length($enc) > 63) { return "" }; # Only support up to 63 chars
339     # (one uuencoded line)
340     my $len = chr(32 + length($enc)*3/4); # uuencode has a length byte at the
341     # beginning
342     return unpack("u", $len.$enc);
343 }
344 sub serve_http_on {
345     my $self = shift;
346     my $ip = shift;
347     my $port = shift;
348     $self->{authuser} = shift;
349     $self->{authpass} = shift;
350     $ip = INADDR_ANY if(!defined($ip) || $ip eq '' || $ip eq '*');
351     $port ||= 81;
352
353     my $handle = IO::Socket->new();
354     socket($handle, PF_INET, SOCK_STREAM, getprotobyname('tcp'))
355         || die "socket: $!";
356     setsockopt($handle, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
357         || die "setsockopt: $!";
358     bind($handle, sockaddr_in($port, $ip))
359         || die "bind: $!";
360     listen($handle,SOMAXCONN);
361
362     $self->{http_port} = $port;
363     $self->{http_ip} = $ip;
364
365     $self->{child} = fork();
366     if($self->{child} == 0) {
367         eval {
368             $SIG{'HUP'} = 'IGNORE';
369             $SIG{'PIPE'} = 'IGNORE';
370             while(my $client = $handle->accept) {
371                 my $req;
372                 my $proto;
373                 my $close_connection;
374                 my $authuser;
375                 my $authpass;
376                 local $SIG{ALRM} = sub { die "timeout\n" };
377                 eval {
378                     alarm($KEEPALIVE_TIMEOUT);
379                     while(<$client>) {
380                         alarm($REQUEST_TIMEOUT);
381                         eval {
382                             s/\r\n/\n/g;
383                             chomp;
384                             if(!$req) {
385                                 if(/^GET \s*(\S+)\s*?(?: HTTP\/(0\.9|1\.0|1\.1)\s*)?$/) {
386                                     $req = $1;
387                                     $proto = $2;
388                                     # Protocol 1.1 and high are keep-alive by
389                                     # default
390                                     $close_connection = ($proto <= 1.0)?1:0;
391                                 }
392                                 elsif(/./) {
393                                     die "protocol deviations.\n";
394                                 }
395                             }
396                             else {
397                                 if(/^$/) {
398                                     $self->service($client, $req, $proto, $close_connection,
399                                         $authuser, $authpass);
400                                     last if ($close_connection);
401                                     alarm($KEEPALIVE_TIMEOUT);
402                                     $req = undef;
403                                     $proto = undef;
404                                 }
405                                 elsif(/^\S+\s*:\s*.{1,4096}$/) {
406                                     # Valid request header... noop
407                                     if(/^Connection: (\S+)/) {
408                                         if(($proto <= 1.0 && lc($2) eq 'keep-alive') ||
409                                             ($proto == 1.1 && lc($2) ne 'close')) {
410                                             $close_connection = 0;
411                                         }
412                                     }
413                                     if(/^Authorization: Basic (\S+)/) {
414                                         my $dec = base64_decode($1);
415                                         ($authuser, $authpass) = split /:/, $dec, 2
416                                     }
417                                 }
418                                 else {
419                                     die "protocol deviations.\n";
420                                 }
421                             }
422                         };
423                         if($@) {
424                             print $client http_header(500, 0, 'text/plain', 1);
425                             print $client "$@\r\n";
426                             last;
427                         }
428                     }
429                     alarm(0);
430                 };
431                 alarm(0) if($@);
432                 $client->close();
433             }
434         };
435         if($@) {
436             print STDERR "Error in listener: $@\n";
437         }
438         exit(0);
439     }
440     close($handle);
441     return;
442 }
443 sub open {
444     my $self = shift;
445     return 0 unless(ref $self);
446     return 1 if($self->{handle});  # Already open
447     if($self->{file} eq '-' || !defined($self->{file})) {
448         # We'll use stdout instead - no file handle needed
449         return 1;
450     }
451     $self->{handle} = IO::File->new("> $self->{file}.swap");
452     die "open $self->{file}.swap failed: $!\n" unless($self->{handle});
453     $self->{swap_on_close} = 1; # move this to a non .swap version on close
454     chmod 0644, "$self->{file}.swap";
455
456     unless(defined($self->{shared_state})) {
457         $self->{shared_state} = shmget(IPC_PRIVATE, $SEGSIZE,
458             IPC_CREAT|S_IRWXU|S_IRWXG|S_IRWXO);
459         die "$0: $!" if($self->{shared_state} == -1);
460     }
461     return 1;
462 }
463 sub store {
464     my ($self, $type, $name, $info) = @_;
465     %{$self->{store}->{$type}->{$name}} = %$info;
466     $self->{store}->{$type}->{$name}->{last_update} = time;
467     $self->store_shared_state();
468 }
469 sub write {
470     # Writes the metrics output for a single check to stdout and/or a file
471     my ($self, $module_name, $check_name, $metrics, $debug) = @_;
472     my $metrics_output = "$module_name`$check_name\n";
473     while (my ($k, $v) = each (%$metrics)) {
474         if (ref($v) eq "ARRAY") {
475             $v = $v->[0];
476         }
477         $metrics_output .= "    $k = $v\n";
478     }
479     if($self->{handle}) {
480         $self->{handle}->print($metrics_output);
481     }
482     if (!$self->{handle} || $debug) {
483         print $metrics_output;
484     }
485 }
486 sub purge {
487     # This removes status information for modules that are no longer loaded
488
489     # Generate list of current modules
490     my %loaded = ();
491     my ($self, $config) = @_;
492     while (my ($type, $mods) = each(%{$config->{Module}}) ) {
493         $loaded{$type} = ();
494         foreach (@$mods) {
495             $loaded{$type}{$_->{'check_name'}} = 1;
496         }
497     }
498
499     # Debugging
500     #while (my ($key, $value) = each(%loaded) ) {
501     #    print STDERR "$key: ";
502     #    while (my ($mod, $dummy) = each (%$value) ) {
503     #        print STDERR "$mod ";
504     #    }
505     #    print "\n";
506     #}
507
508     # Compare $self->{store} with list of loaded modules
509     while (my ($type, $value) = each (%{$self->{store}})) {
510         while (my ($name, $value2) = each (%$value)) {
511             if (!exists($loaded{$type}) || !exists($loaded{$type}{$name})) {
512                 #print STDERR "$type $name\n";
513                 delete $self->{store}->{$type}->{$name};
514                 if (scalar(keys %{$self->{store}->{$type}}) == 0) {
515                     #print STDERR "$type has no more objects, deleting\n";
516                     delete $self->{store}->{$type};
517                 }
518             }
519         }
520     }
521 }
522 sub close {
523     my $self = shift;
524     $self->{handle}->close() if($self->{handle});
525     $self->{handle} = undef;
526     if($self->{swap_on_close}) {
527         unlink("$self->{file}");
528         link("$self->{file}.swap", $self->{file});
529         unlink("$self->{file}.swap");
530         delete($self->{swap_on_close});
531     }
532 }
533 sub DESTROY {
534     my $self = shift;
535     my $child = $self->{child};
536     if($child) {
537         kill 15, $child;
538         sleep 1;
539         kill 9, $child if(kill 0, $child);
540         waitpid(-1,WNOHANG);
541     }
542     if(defined($self->{shared_state})) {
543         shmctl($self->{shared_state}, IPC_RMID, 0);
544     }
545 }
546 1;
Note: See TracBrowser for help on using the browser.