root/lib/Resmon/Status.pm

Revision a6107a6231489f3950e6d41ad6bb5cb337536037, 16.3 kB (checked in by Mark Harrison <mark@omniti.com>, 5 years ago)

Allow a type attribute to be associated with a message

git-svn-id: https://labs.omniti.com/resmon/trunk@214 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 ftok 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     $rv .= " " x $indent;
59     if(ref $value eq 'HASH') {
60       $rv .= "<$key>\n";
61       $rv .= xml_kv_dump($value, $indent + 2);
62       $rv .= " " x $indent;
63       $rv .= "</$key>\n";
64     } elsif (ref $value eq 'ARRAY') {
65       # A value/type pair
66       my $type = $value->[1];
67       if ($type !~ /^[0iIlLns]$/) {
68         $type = "0";
69       }
70       $value = $value->[0];
71       $value =~ s/&/&amp;/g;
72       $value =~ s/</&lt;/g;
73       $value =~ s/>/&gt;/g;
74       $value =~ s/'/&apos;/g;
75       $rv .= "<$key type=\"$type\">$value</$key>\n";
76     } else {
77       $value =~ s/&/&amp;/g;
78       $value =~ s/</&lt;/g;
79       $value =~ s/>/&gt;/g;
80       $value =~ s/'/&apos;/g;
81       $rv .= "<$key>$value</$key>\n";
82     }
83   }
84   return $rv;
85 }
86 sub xml_info {
87   my ($module, $service, $info) = @_;
88   my $rv = '';
89   $rv .= "  <ResmonResult module=\"$module\" service=\"$service\">\n";
90   $rv .= xml_kv_dump($info, 4);
91   $rv .= "  </ResmonResult>\n";
92   return $rv;
93 }
94 sub dump_generic {
95   my $self = shift;
96   my $dumper = shift;
97   my $rv = '';
98   while(my ($module, $services) = each %{$self->{store}}) {
99     while(my ($service, $info) = each %$services) {
100       $rv .= $dumper->($module,$service,$info);
101     }
102   }
103   return $rv;
104 }
105 sub dump_generic_module {
106   # Dumps a single module rather than all checks
107   my $self = shift;
108   my $dumper = shift;
109   my $module = shift;
110   my $rv = '';
111   my $services = $self->{store}->{$module};
112   while(my ($service, $info) = each %$services) {
113     $rv .= $dumper->($module,$service,$info);
114   }
115   return $rv;
116 }
117 sub dump_generic_state {
118   # Dumps only checks with a specific state
119   my $self = shift;
120   my $dumper = shift;
121   my $state = shift;
122   my $rv = '';
123   while(my ($module, $services) = each %{$self->{store}}) {
124     while(my ($service, $info) = each %$services) {
125       if ($info->{state} eq $state) {
126         $rv .= $dumper->($module,$service,$info);
127       }
128     }
129   }
130   return $rv;
131 }
132 sub dump_oldstyle {
133   my $self = shift;
134   my $response = $self->dump_generic(sub {
135     my($module,$service,$info) = @_;
136     my $message = $info->{message};
137     if (ref $message eq "ARRAY") {
138         $message = $message->[0];
139     }
140     return "$service($module) :: $info->{state}($message)\n";
141   });
142   return $response;
143 }
144 sub dump_xml {
145   my $self = shift;
146   my $response = <<EOF
147 <?xml version="1.0" encoding="UTF-8"?>
148 <?xml-stylesheet type="text/xsl" href="/resmon.xsl"?>
149 <ResmonResults>
150 EOF
151   ;
152   $response .= $self->dump_generic(\&xml_info);
153   $response .= "</ResmonResults>\n";
154   return $response;
155 }
156 sub get_xsl() {
157   my $response = <<EOF
158 <?xml version="1.0" encoding="ISO-8859-1"?>
159 <xsl:stylesheet version="1.0"
160     xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
161 <xsl:template match="ResmonResults">
162 <html>
163 <head>
164     <title>Resmon Results</title>
165     <link rel="stylesheet" type="text/css" href="/resmon.css" />
166 </head>
167 <body>
168     <ul class="navbar">
169         <li><a href="/">List all checks</a></li>
170         <li><a href="/BAD">List all checks that are BAD</a></li>
171         <li><a href="/WARNING">List all checks that are WARNING</a></li>
172         <li><a href="/OK">List all checks that are OK</a></li>
173     </ul>
174     <p>
175     Total checks:
176     <xsl:value-of select="count(ResmonResult)" />
177     </p>
178     <xsl:for-each select="ResmonResult">
179         <xsl:sort select="\@module" />
180         <xsl:sort select="\@service" />
181         <div class="item">
182                 <xsl:attribute name="class">
183                     item <xsl:value-of select="state" />
184                 </xsl:attribute>
185             <ul class="info">
186                 <li>Time taken for last check:
187                     <xsl:value-of select="last_runtime_seconds" /></li>
188                 <li>Last updated:
189                     <xsl:value-of select="last_update" /></li>
190             </ul>
191             <h1>
192                 <a>
193                     <xsl:attribute name="href">
194                         /<xsl:value-of select="\@module" />
195                     </xsl:attribute>
196                     <xsl:value-of select="\@module" />
197                 </a>
198                 -
199                 <a>
200                     <xsl:attribute name="href">
201                         /<xsl:value-of select="\@module"
202                             />/<xsl:value-of select="\@service" />
203                     </xsl:attribute>
204                     <xsl:value-of select="\@service" />
205                 </a>
206             </h1>
207             <h2>
208                 <xsl:value-of select="state"/>:
209                 <xsl:value-of select="message" />
210             </h2>
211             <a class="config" href="#">
212                 Hover to view configuration...
213                 <table>
214                     <tr>
215                         <th>Name</th>
216                         <th>Value</th>
217                     </tr>
218                     <xsl:for-each select="configuration/*">
219                         <xsl:sort select="name(.)" />
220                         <tr>
221                             <td><xsl:value-of select="name(.)" /></td>
222                             <td><xsl:value-of select="." /></td>
223                         </tr>
224                     </xsl:for-each>
225                 </table>
226             </a>
227         </div>
228     </xsl:for-each>
229 </body>
230 </html>
231 </xsl:template>
232 </xsl:stylesheet>
233 EOF
234   ;
235   return $response;
236 }
237 sub get_css() {
238   my $response=<<EOF
239 body {
240     font-family: Verdana, Arial, helvetica, sans-serif;
241 }
242 h1 {
243     margin: 0;
244     font-size: 120%;
245 }
246
247 h2 {
248     margin: 0;
249     font-sizE: 110%;
250 }
251
252 .item {
253     border: 1px solid black;
254     padding: 1em;
255     margin: 2em;
256     background-color: #eeeeee;
257 }
258
259 a.config {
260     color: black;
261 }
262
263 a.config:visited {
264     color: black;
265 }
266
267 a.config table {
268     display: none
269 }
270
271 a.config:hover table {
272     display: block;
273     position: fixed;
274     top: 1em;
275     right: 1em;
276     max-width: 95%;
277     overflow: hidden;
278 }
279
280 .info {
281     float: right;
282     font-size: 80%;
283     padding: 0;
284     margin: 0;
285 }
286
287 .OK {
288     background-color: #afa;
289 }
290
291 .WARNING {
292     background-color: #ffa;
293 }
294
295 .BAD {
296     background-color: #faa;
297 }
298
299 table {
300     border: 1px solid black;
301     background-color: #eeeeee;
302     border-collapse: collapse;
303     margin: 1em;
304     font-size: 80%;
305 }
306
307 th {
308     font-size: 100%;
309     font-weight: bold;
310     background-color: black;
311     color: white;
312 }
313
314 td {
315     padding-left: 1em;
316     padding-right: 1em;
317 }
318
319 a {
320     text-decoration: none;
321 }
322
323 ul.navbar {
324     list-style: none;
325     font-size: 80%;
326 }
327 ul.navbar li {
328     display: inline;
329     padding-left: 1em;
330     padding-right: 1em;
331     margin-right: -1px;
332     border-left: 1px solid black;
333     border-right: 1px solid black;
334 }
335 EOF
336   ;
337   return $response;
338 }
339 sub service {
340   my $self = shift;
341   my ($client, $req, $proto, $snip) = @_;
342   my $state = $self->get_shared_state();
343   if($req eq '/' or $req eq '/status') {
344     my $response .= $self->dump_xml();
345     $client->print(http_header(200, length($response), 'text/xml', $snip));
346     $client->print($response . "\r\n");
347     return;
348   } elsif($req eq '/status.txt') {
349     my $response = $self->dump_oldstyle();
350     $client->print(http_header(200, length($response), 'text/plain', $snip));
351     $client->print($response . "\r\n");
352     return;
353   } elsif($req eq '/resmon.xsl') {
354     my $response = $self->get_xsl();
355     $client->print(http_header(200, length($response), 'text/xml', $snip));
356     $client->print($response . "\r\n");
357     return;
358   } elsif($req eq '/resmon.css') {
359     my $response = $self->get_css();
360     $client->print(http_header(200, length($response), 'text/css', $snip));
361     $client->print($response . "\r\n");
362     return;
363   } elsif($req =~ /^\/([^\/]+)\/(.+)$/) {
364     if(exists($self->{store}->{$1}) &&
365         exists($self->{store}->{$1}->{$2})) {
366     my $info = $self->{store}->{$1}->{$2};
367     my $response = qq^<?xml version="1.0" encoding="UTF-8"?>\n^;
368     my $response .= qq^<?xml-stylesheet type="text/xsl" href="/resmon.xsl"?>^;
369     $response .= "<ResmonResults>\n".
370                     xml_info($1,$2,$info).
371                     "</ResmonResults>\n";
372     $client->print(http_header(200, length($response), 'text/xml', $snip));
373     $client->print( $response . "\r\n");
374     return;
375     }
376   } elsif($req =~ /^\/([^\/]+)$/) {
377     if ($1 eq "BAD" || $1 eq "OK" || $1 eq "WARNING") {
378       my $response = qq^<?xml version="1.0" encoding="UTF-8"?>\n^;
379       my $response .= qq^<?xml-stylesheet type="text/xsl" href="/resmon.xsl"?>^;
380       $response .= "<ResmonResults>\n".
381                       $self->dump_generic_state(\&xml_info,$1) .
382                       "</ResmonResults>\n";
383       $client->print(http_header(200, length($response), 'text/xml', $snip));
384       $client->print( $response . "\r\n");
385       return;
386     } elsif(exists($self->{store}->{$1})) {
387       my $response = qq^<?xml version="1.0" encoding="UTF-8"?>\n^;
388       my $response .= qq^<?xml-stylesheet type="text/xsl" href="/resmon.xsl"?>^;
389       $response .= "<ResmonResults>\n".
390                       $self->dump_generic_module(\&xml_info,$1) .
391                       "</ResmonResults>\n";
392       $client->print(http_header(200, length($response), 'text/xml', $snip));
393       $client->print( $response . "\r\n");
394       return;
395     }
396   }
397   die "Request not understood\n";
398 }
399 sub http_header {
400   my $code = shift;
401   my $len = shift;
402   my $type = shift || 'text/xml';
403   my $close_connection = shift || 1;
404   return qq^HTTP/1.0 $code OK
405 Server: resmon
406 ^ . (defined($len) ? "Content-length: $len\n" : "") .
407     (($close_connection || !$len) ? "Connection: close\n" : "") .
408 qq^Content-Type: $type; charset=utf-8
409
410 ^;
411 }
412 sub serve_http_on {
413   my $self = shift;
414   my $ip = shift;
415   my $port = shift;
416   $ip = INADDR_ANY if(!defined($ip) || $ip eq '' || $ip eq '*');
417   $port ||= 81;
418
419   my $handle = IO::Socket->new();
420   socket($handle, PF_INET, SOCK_STREAM, getprotobyname('tcp'))
421     || die "socket: $!";
422   setsockopt($handle, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
423     || die "setsockopt: $!";
424   bind($handle, sockaddr_in($port, $ip))
425     || die "bind: $!";
426   listen($handle,SOMAXCONN);
427
428   $self->{zindex} = 0;
429   if (-x "/usr/sbin/zoneadm") {
430     open(Z, "/usr/sbin/zoneadm list -p |");
431     my $firstline = <Z>;
432     close(Z);
433     ($self->{zindex}) = split /:/, $firstline, 2;
434   }
435   $self->{http_port} = $port;
436   $self->{http_ip} = $ip;
437   $self->{ftok_number} = $port * (1 + $self->{zindex});
438
439   $self->{child} = fork();
440   if($self->{child} == 0) {
441     eval {
442       $SIG{'HUP'} = 'IGNORE';
443       $SIG{'PIPE'} = 'IGNORE';
444       while(my $client = $handle->accept) {
445         my $req;
446         my $proto;
447         my $close_connection;
448         local $SIG{ALRM} = sub { die "timeout\n" };
449         eval {
450           alarm($KEEPALIVE_TIMEOUT);
451           while(<$client>) {
452             alarm($REQUEST_TIMEOUT);
453             eval {
454               s/\r\n/\n/g;
455               chomp;
456               if(!$req) {
457                 if(/^GET \s*(\S+)\s*?(?: HTTP\/(0\.9|1\.0|1\.1)\s*)?$/) {
458                   $req = $1;
459                   $proto = $2;
460                   # Protocol 1.1 and high are keep-alive by default
461                   $close_connection = ($proto <= 1.0)?1:0;
462                 }
463                 elsif(/./) {
464                   die "protocol deviations.\n";
465                 }
466               }
467               else {
468                 if(/^$/) {
469                   $self->service($client, $req, $proto, $close_connection);
470                   last if ($close_connection);
471                   alarm($KEEPALIVE_TIMEOUT);
472                   $req = undef;
473                   $proto = undef;
474                 }
475                 elsif(/^\S+\s*:\s*.{1,4096}$/) {
476                   # Valid request header... noop
477                   if(/^Connection: (\S+)/) {
478                     if(($proto <= 1.0 && lc($2) eq 'keep-alive') ||
479                        ($proto == 1.1 && lc($2) ne 'close')) {
480                       $close_connection = 0;
481                     }
482                   }
483                 }
484                 else {
485                   die "protocol deviations.\n";
486                 }
487               }
488             };
489             if($@) {
490               print $client http_header(500, 0, 'text/plain', 1);
491               print $client "$@\r\n";
492               last;
493             }
494           }
495           alarm(0);
496         };
497         alarm(0) if($@);
498         $client->close();
499       }
500     };
501     if($@) {
502       print STDERR "Error in listener: $@\n";
503     }
504     exit(0);
505   }
506   close($handle);
507   return;
508 }
509 sub open {
510   my $self = shift;
511   return 0 unless(ref $self);
512   return 1 if($self->{handle});  # Alread open
513   if($self->{file} eq '-' || !defined($self->{file})) {
514     $self->{handle_is_stdout} = 1;
515     $self->{handle} = IO::File->new_from_fd(fileno(STDOUT), "w");
516     return 1;
517   }
518   $self->{handle} = IO::File->new("> $self->{file}.swap");
519   die "open $self->{file}.swap failed: $!\n" unless($self->{handle});
520   $self->{swap_on_close} = 1; # move this to a non .swap version on close
521   chmod 0644, "$self->{file}.swap";
522
523   unless(defined($self->{shared_state})) {
524     $self->{shared_state} = shmget(IPC_PRIVATE, $SEGSIZE,
525                                    IPC_CREAT|S_IRWXU|S_IRWXG|S_IRWXO);
526     die "$0: $!" if($self->{shared_state} == -1);
527   }
528   return 1;
529 }
530 sub store {
531   my ($self, $type, $name, $info) = @_;
532   %{$self->{store}->{$type}->{$name}} = %$info;
533   $self->{store}->{$type}->{$name}->{last_update} = time;
534   $self->store_shared_state();
535   my $message = $info->{message};
536   if (ref $message eq "ARRAY") {
537     $message = $message->[0];
538   }
539   if($self->{handle}) {
540     $self->{handle}->print("$name($type) :: $info->{state}($message)\n");
541   } else {
542     print "$name($type) :: $info->{state}($message)\n";
543   }
544 }
545 sub purge {
546     # This removes status information for modules that are no longer loaded
547
548     # Generate list of current modules
549     my %loaded = ();
550     my ($self, $config) = @_;
551     while (my ($type, $mods) = each(%{$config->{Module}}) ) {
552         $loaded{$type} = ();
553         foreach (@$mods) {
554             $loaded{$type}{$_->{'object'}} = 1;
555         }
556     }
557
558     # Debugging
559     #while (my ($key, $value) = each(%loaded) ) {
560     #    print STDERR "$key: ";
561     #    while (my ($mod, $dummy) = each (%$value) ) {
562     #        print STDERR "$mod ";
563     #    }
564     #    print "\n";
565     #}
566
567     # Compare $self->{store} with list of loaded modules
568     while (my ($type, $value) = each (%{$self->{store}})) {
569         while (my ($name, $value2) = each (%$value)) {
570             if (!exists($loaded{$type}) || !exists($loaded{$type}{$name})) {
571                 #print STDERR "$type $name\n";
572                 delete $self->{store}->{$type}->{$name};
573                 if (scalar(keys %{$self->{store}->{$type}}) == 0) {
574                     #print STDERR "$type has no more objects, deleting\n";
575                     delete $self->{store}->{$type};
576                 }
577             }
578         }
579     }
580 }
581 sub close {
582   my $self = shift;
583   return if($self->{handle_is_stdout});
584   $self->{handle}->close() if($self->{handle});
585   $self->{handle} = undef;
586   if($self->{swap_on_close}) {
587     unlink("$self->{file}");
588     link("$self->{file}.swap", $self->{file});
589     unlink("$self->{file}.swap");
590     delete($self->{swap_on_close});
591   }
592 }
593 sub DESTROY {
594   my $self = shift;
595   my $child = $self->{child};
596   if($child) {
597     kill 15, $child;
598     sleep 1;
599     kill 9, $child if(kill 0, $child);
600     waitpid(-1,WNOHANG);
601   }
602   if(defined($self->{shared_state})) {
603     shmctl($self->{shared_state}, IPC_RMID, 0);
604   }
605 }
606 1;
Note: See TracBrowser for help on using the browser.