root/lib/Resmon/Status.pm

Revision 0e5f64d7572f24c142e6ef6357ee94733dad2b54, 15.5 kB (checked in by Mark Harrison <mark@omniti.com>, 8 years ago)

Fix malformed XML when using hashes as results

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