root/lib/Resmon/Status.pm

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

Add locking when reading/writing resmon state.

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

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