root/lib/Resmon/Status.pm

Revision a3ac1576f50568b5809883c6079ff8398ef2eff5, 12.4 kB (checked in by Mark Harrison <mark@omniti.com>, 6 years ago)

Added a purge method to status that will remove any status information for
modules that are no longer loaded (due to them being removed from the config
file and resmon being reloaded). This required $status to become global so it
was accessible from the reload_modules command.

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