root/lib/Resmon/Status.pm

Revision 8657b1c93255fbc6381e85d10b749f1883265203, 8.3 kB (checked in by Theo Schlossnagle <jesus@omniti.com>, 7 years ago)

If for some reason the client just disconnects and the read fails (or we die from our eval) we must reset the alarm or it will kill us off. closes #1

git-svn-id: https://labs.omniti.com/resmon/trunk@44 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_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($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($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       $rv .= "<$key>$value</$key>\n";
67     }
68   }
69   return $rv;
70 }
71 sub xml_info {
72   my ($module, $service, $info) = @_;
73   my $rv = '';
74   $rv .= "  <ResmonResult module=\"$module\" service=\"$service\">\n";
75   $rv .= xml_kv_dump($info, 4);
76   $rv .= "  </ResmonResult>\n";
77   return $rv;
78 }
79 sub dump_generic {
80   my $self = shift;
81   my $dumper = shift;
82   my $rv = '';
83   while(my ($module, $services) = each %{$self->{store}}) {
84     while(my ($service, $info) = each %$services) {
85       $rv .= $dumper->($module,$service,$info);
86     }
87   }
88   return $rv;
89 }
90 sub dump_oldstyle {
91   my $self = shift;
92   my $response = $self->dump_generic(sub {
93     my($module,$service,$info) = @_;
94     return "$service($module) :: $info->{state}($info->{message})\n";
95   });
96   return $response;
97 }
98 sub dump_xml {
99   my $self = shift;
100   my $response = <<EOF
101 <?xml version="1.0" encoding="UTF-8"?>
102 <ResmonResults>
103 EOF
104   ;
105   $response .= $self->dump_generic(\&xml_info);
106   $response .= "</ResmonResults>\n";
107   return $response;
108 }
109 sub service {
110   my $self = shift;
111   my ($client, $req, $proto, $snip) = @_;
112   my $state = $self->get_shared_state();
113   if($req eq '/' or $req eq '/status') {
114     my $response .= $self->dump_xml();
115     $client->print(http_header(200, length($response), 'text/xml', $snip));
116     $client->print($response . "\r\n");
117     return;
118   } elsif($req eq '/status.txt') {
119     my $response = $self->dump_oldstyle();
120     $client->print(http_header(200, length($response), 'text/plain', $snip));
121     $client->print($response . "\r\n");
122     return;
123   } else {
124     if($req =~ /^\/([^\/]+)\/(.+)$/) {
125       if(exists($self->{store}->{$1}) &&
126          exists($self->{store}->{$1}->{$2})) {
127         my $info = $self->{store}->{$1}->{$2};
128         my $response = qq^<?xml version="1.0" encoding="UTF-8"?>\n^;
129         $response .= "<ResmonResults>\n".
130                      xml_info($1,$2,$info).
131                      "</ResmonRestults>\n";
132         $client->print(http_header(200, length($response), 'text/xml', $snip));
133         $client->print( $response . "\r\n");
134         return;
135       }
136     }
137   }
138   die "Request not understood\n";
139 }
140 sub http_header {
141   my $code = shift;
142   my $len = shift;
143   my $type = shift || 'text/xml';
144   my $close_connection = shift || 1;
145   return qq^HTTP/1.0 $code OK
146 Server: resmon
147 ^ . (defined($len) ? "Content-length: $len\n" : "") .
148     (($close_connection || !$len) ? "Connection: close\n" : "") .
149 qq^Content-Type: $type; charset=utf-8
150
151 ^;
152 }
153 sub serve_http_on {
154   my $self = shift;
155   my $ip = shift;
156   my $port = shift;
157   $ip = INADDR_ANY if(!defined($ip) || $ip eq '' || $ip eq '*');
158   $port ||= 81;
159
160   my $handle = IO::Socket->new();
161   socket($handle, PF_INET, SOCK_STREAM, getprotobyname('tcp'))
162     || die "socket: $!";
163   setsockopt($handle, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
164     || die "setsockopt: $!";
165   bind($handle, sockaddr_in($port, $ip))
166     || die "bind: $!";
167   listen($handle,SOMAXCONN);
168
169   $self->{zindex} = 0;
170   if (-x "/usr/sbin/zoneadm") {
171     open(Z, "/usr/sbin/zoneadm list -p |");
172     my $firstline = <Z>;
173     close(Z);
174     ($self->{zindex}) = split /:/, $firstline, 2;
175   }
176   $self->{http_port} = $port;
177   $self->{http_ip} = $ip;
178   $self->{ftok_number} = $port * (1 + $self->{zindex});
179
180   $self->{child} = fork();
181   if($self->{child} == 0) {
182     eval {
183       while(my $client = $handle->accept) {
184         my $req;
185         my $proto;
186         my $close_connection;
187         local $SIG{ALRM} = sub { die "timeout\n" };
188         eval {
189           alarm($KEEPALIVE_TIMEOUT);
190           while(<$client>) {
191             alarm($REQUEST_TIMEOUT);
192             eval {
193               s/\r\n/\n/g;
194               chomp;
195               if(!$req) {
196                 if(/^GET \s*(\S+)\s*?(?: HTTP\/(0\.9|1\.0|1\.1)\s*)?$/) {
197                   $req = $1;
198                   $proto = $2;
199                   # Protocol 1.1 and high are keep-alive by default
200                   $close_connection = ($proto <= 1.0)?1:0;
201                 }
202                 elsif(/./) {
203                   die "protocol deviations.\n";
204                 }
205               }
206               else {
207                 if(/^$/) {
208                   $self->service($client, $req, $proto, $close_connection);
209                   last if ($close_connection);
210                   alarm($KEEPALIVE_TIMEOUT);
211                   $req = undef;
212                   $proto = undef;
213                 }
214                 elsif(/^\S+\s*:\s*.{1,4096}$/) {
215                   # Valid request header... noop
216                   if(/^Connection: (\S+)/) {
217                     if(($proto <= 1.0 && lc($2) eq 'keep-alive') ||
218                        ($proto == 1.1 && lc($2) ne 'close')) {
219                       $close_connection = 0;
220                     }
221                   }
222                 }
223                 else {
224                   die "protocol deviations.\n";
225                 }
226               }
227             };
228             if($@) {
229               print $client http_header(500, 0, 'text/plain', 1);
230               print $client "$@\r\n";
231               last;
232             }
233           }
234           alarm(0);
235         };
236         alarm(0) if($@);
237         $client->close();
238       }
239     };
240     if($@) {
241       print STDERR "Error in listener: $@\n";
242     }
243     exit(0);
244   }
245   close($handle);
246   return;
247 }
248 sub open {
249   my $self = shift;
250   return 0 unless(ref $self);
251   return 1 if($self->{handle});  # Alread open
252   if($self->{file} eq '-' || !defined($self->{file})) {
253     $self->{handle_is_stdout} = 1;
254     $self->{handle} = IO::File->new_from_fd(fileno(STDOUT), "w");
255     return 1;
256   }
257   $self->{handle} = IO::File->new("> $self->{file}.swap");
258   die "open $self->{file}.swap failed: $!\n" unless($self->{handle});
259   $self->{swap_on_close} = 1; # move this to a non .swap version on close
260   chmod 0644, "$self->{file}.swap";
261
262   unless($self->{shared_state}) {
263     my $id = ftok(__FILE__,$self->{ftok_number});
264     $self->{shared_state} = shmget($id, $SEGSIZE,
265                                    IPC_CREAT|S_IRWXU|S_IRWXG|S_IRWXO)
266       || die "$0: $!";
267   }
268   return 1;
269 }
270 sub store {
271   my ($self, $type, $name, $info) = @_;
272   %{$self->{store}->{$type}->{$name}} = %$info;
273   $self->{store}->{$type}->{$name}->{last_update} = time;
274   $self->store_shared_state();
275   if($self->{handle}) {
276     $self->{handle}->print("$name($type) :: $info->{state}($info->{message})\n");
277   } else {
278     print "$name($type) :: $info->{state}($info->{message})\n";
279   }
280 }
281 sub close {
282   my $self = shift;
283   return if($self->{handle_is_stdout});
284   $self->{handle}->close() if($self->{handle});
285   $self->{handle} = undef;
286   if($self->{swap_on_close}) {
287     unlink("$self->{file}");
288     link("$self->{file}.swap", $self->{file});
289     unlink("$self->{file}.swap");
290     delete($self->{swap_on_close});
291   }
292 }
293 sub DESTROY {
294   my $self = shift;
295   my $child = $self->{child};
296   if($child) {
297     kill 15, $child;
298     sleep 1;
299     kill 9, $child if(kill 0, $child);
300     waitpid(-1,WNOHANG);
301   }
302   if($self->{shared_state}) {
303     shmctl($self->{shared_state}, IPC_RMID, 0);
304   }
305 }
306 1;
Note: See TracBrowser for help on using the browser.