root/lib/Resmon/Status.pm

Revision 9c26e336e64dadcca9eb4edb586d8ab43c6754e2, 7.1 kB (checked in by Eric Sproul <esproul@omniti.com>, 11 years ago)

Fix status file handling per Theo

git-svn-id: https://labs.omniti.com/resmon/trunk@37 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 sub new {
15   my $class = shift;
16   my $file = shift;
17   return bless {
18     file => $file
19   }, $class;
20 }
21 sub get_shared_state {
22   my $self = shift;
23   my $blob;
24   my $len;
25   return unless($self->{shared_state});
26   # Lock shared segment
27   # Read in
28   shmread($self->{shared_state}, $len, 0, length(pack('i', 0)));
29   $len = unpack('i', $len);
30   shmread($self->{shared_state}, $blob, length(pack('i', 0)), $len);
31   # unlock
32   my $VAR1;
33   eval $blob;
34   die $@ if ($@);
35   $self->{store} = $VAR1;
36   return $self->{store};
37 }
38 sub store_shared_state {
39   my $self = shift;
40   return unless($self->{shared_state});
41   my $blob = Dumper($self->{store});
42
43   # Lock shared segment
44   # Write state and flush
45   shmwrite($self->{shared_state}, pack('i', length($blob)),
46            0, length(pack('i', 0))) || die "$!";
47   shmwrite($self->{shared_state}, $blob, length(pack('i', 0)),
48            length($blob)) || die "$!";
49   # unlock
50 }
51 sub xml_kv_dump {
52   my $info = shift;
53   my $indent = shift || 0;
54   my $rv = '';
55   while(my ($key, $value) = each %$info) {
56     $rv .= " " x $indent;
57     if(ref $value eq 'HASH') {
58       $rv .= "<$key>\n";
59       $rv .= xml_kv_dump($value, $indent + 2);
60       $rv .= " " x $indent;
61       $rv .= "</$key>\n";
62     }
63     else {
64       $rv .= "<$key>$value</$key>\n";
65     }
66   }
67   return $rv;
68 }
69 sub xml_info {
70   my ($module, $service, $info) = @_;
71   my $rv = '';
72   $rv .= "  <ResmonResult module=\"$module\" service=\"$service\">\n";
73   $rv .= xml_kv_dump($info, 4);
74   $rv .= "  </ResmonResult>\n";
75   return $rv;
76 }
77 sub dump_generic {
78   my $self = shift;
79   my $dumper = shift;
80   my $rv = '';
81   while(my ($module, $services) = each %{$self->{store}}) {
82     while(my ($service, $info) = each %$services) {
83       $rv .= $dumper->($module,$service,$info);
84     }
85   }
86   return $rv;
87 }
88 sub dump_oldstyle {
89   my $self = shift;
90   my $response = $self->dump_generic(sub {
91     my($module,$service,$info) = @_;
92     return "$service($module) :: $info->{state}($info->{message})\n";
93   });
94   return $response;
95 }
96 sub dump_xml {
97   my $self = shift;
98   my $response = <<EOF
99 <?xml version="1.0" encoding="UTF-8"?>
100 <ResmonResults>
101 EOF
102   ;
103   $response .= $self->dump_generic(\&xml_info);
104   $response .= "</ResmonResults>\n";
105   return $response;
106 }
107 sub service {
108   my $self = shift;
109   my ($client, $req, $proto) = @_;
110   my $state = $self->get_shared_state();
111   if($req eq '/' or $req eq '/status') {
112     my $response .= $self->dump_xml();
113     $client->print(http_header(200, $proto?length($response):0));
114     $client->print($response . "\r\n");
115     return;
116   } elsif($req eq '/status.txt') {
117     my $response = $self->dump_oldstyle();
118     $client->print(http_header(200, $proto?length($response):0, 'text/plain'));
119     $client->print($response . "\r\n");
120     return;
121   } else {
122     if($req =~ /^\/([^\/]+)\/(.+)$/) {
123       if(exists($self->{store}->{$1}) &&
124          exists($self->{store}->{$1}->{$2})) {
125         my $info = $self->{store}->{$1}->{$2};
126         my $response = qq^<?xml version="1.0" encoding="UTF-8"?>\n^;
127         $response .= "<ResmonResults>\n".
128                      xml_info($1,$2,$info).
129                      "</ResmonRestults>\n";
130         $client->print(http_header(200, $proto?length($response):0));
131         $client->print( $response . "\r\n");
132         return;
133       }
134     }
135   }
136   die "Request not understood\n";
137 }
138 sub http_header {
139   my $code = shift;
140   my $len = shift;
141   my $type = shift || 'text/xml';
142   return qq^HTTP/1.0 $code OK
143 Server: resmon
144 ^ . (defined($len) ? "Content-length: $len" : "Connection: close") . q^
145 Content-Type: text/plain; charset=utf-8
146
147 ^;
148 }
149 sub serve_http_on {
150   my $self = shift;
151   my $ip = shift;
152   my $port = shift;
153   $ip = INADDR_ANY if(!defined($ip) || $ip eq '' || $ip eq '*');
154   $port ||= 81;
155
156   my $handle = IO::Socket->new();
157   socket($handle, PF_INET, SOCK_STREAM, getprotobyname('tcp'))
158     || die "socket: $!";
159   setsockopt($handle, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
160     || die "setsockopt: $!";
161   bind($handle, sockaddr_in($port, $ip))
162     || die "bind: $!";
163   listen($handle,SOMAXCONN);
164
165   $self->{http_port} = $port;
166   $self->{http_ip} = $ip;
167
168   $self->{child} = fork();
169   if($self->{child} == 0) {
170     eval {
171       while(my $client = $handle->accept) {
172         my $req;
173         my $proto;
174         while(<$client>) {
175           eval {
176             s/\r\n/\n/g;
177             chomp;
178             if(!$req) {
179               if(/^GET \s*(\S+)\s*?(?: HTTP\/(0\.9|1\.0|1\.1)\s*)?$/) {
180                 $req = $1;
181                 $proto = $2;
182               }
183               else {
184                 die "protocol deviations.\n";
185               }
186             }
187             elsif(/^$/) {
188               $self->service($client, $req, $proto);
189               last unless ($proto);
190               $req = undef;
191               $proto = undef;
192             }
193             elsif(/^\S+\s*:\s*.{1,4096}$/) {
194               # Valid request header... noop
195             }
196             else {
197               die "protocol deviations.\n";
198             }
199           };
200           if($@) {
201             print $client http_header(500, 0, 'text/plain');
202             print $client "$@\r\n";
203             last;
204           }
205         }
206         $client->close();
207       }
208     };
209     if($@) {
210       print STDERR "Error in listener: $@\n";
211     }
212     exit(0);
213   }
214   close($handle);
215   return;
216 }
217 sub open {
218   my $self = shift;
219   return 0 unless(ref $self);
220   return 1 if($self->{handle});  # Alread open
221   if($self->{file} eq '-' || !defined($self->{file})) {
222     $self->{handle_is_stdout} = 1;
223     $self->{handle} = IO::File->new_from_fd(fileno(STDOUT), "w");
224     return 1;
225   }
226   $self->{handle} = IO::File->new("> $self->{file}.swap");
227   die "open $self->{file}.swap failed: $!\n" unless($self->{handle});
228   $self->{swap_on_close} = 1; # move this to a non .swap version on close
229   chmod 0644, "$self->{file}.swap";
230
231   unless($self->{shared_state}) {
232     my $id = ftok(__FILE__,$self->{http_port});
233     $self->{shared_state} = shmget($id, $SEGSIZE,
234                                    IPC_CREAT|S_IRWXU|S_IRWXG|S_IRWXO)
235       || die "$0: $!";
236   }
237   return 1;
238 }
239 sub store {
240   my ($self, $type, $name, $info) = @_;
241   %{$self->{store}->{$type}->{$name}} = %$info;
242   $self->{store}->{$type}->{$name}->{last_update} = time;
243   $self->store_shared_state();
244   if($self->{handle}) {
245     $self->{handle}->print("$name($type) :: $info->{state}($info->{message})\n");
246   } else {
247     print "$name($type) :: $info->{state}($info->{message})\n";
248   }
249 }
250 sub close {
251   my $self = shift;
252   return if($self->{handle_is_stdout});
253   $self->{handle}->close() if($self->{handle});
254   $self->{handle} = undef;
255   if($self->{swap_on_close}) {
256     unlink("$self->{file}");
257     link("$self->{file}.swap", $self->{file});
258     unlink("$self->{file}.swap");
259     delete($self->{swap_on_close});
260   }
261 }
262 sub DESTROY {
263   my $self = shift;
264   my $child = $self->{child};
265   if($child) {
266     kill 15, $child;
267     sleep 1;
268     kill 9, $child if(kill 0, $child);
269     waitpid(-1,WNOHANG);
270   }
271   if($self->{shared_state}) {
272     shmctl($self->{shared_state}, IPC_RMID, 0);
273   }
274 }
275 1;
Note: See TracBrowser for help on using the browser.