LP#1739044: fix lock file detection in eg-pbx-allocator.pl
[Evergreen.git] / Open-ILS / src / asterisk / pbx-daemon / eg-pbx-allocator.pl
1 #!/usr/bin/perl -w
2 #
3 # Copyright (C) 2009 Equinox Software, Inc.
4 #
5 # License:
6 #
7 # This program is free software; you can redistribute it and/or
8 # modify it under the terms of the GNU General Public License
9 # as published by the Free Software Foundation; either version 2
10 # of the License, or (at your option) any later version.
11 #
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 # GNU General Public License for more details.
16 #
17
18 =head1 NAME
19
20 allocator.pl
21
22 =head1 SYNOPSIS
23
24 allocator.pl [-h] [-t] [-v] [-c <file>]
25
26  Options:
27    -h         display help message
28    -t         test mode, no files are moved (impies -v)
29    -v         give verbose feedback
30    -c <file>  specify config file to be used
31
32 =head1 DESCRIPTION
33
34 This script is designed to run from crontab on a very frequent basis, perhaps
35 every minute.  It has two purposes:
36
37 =over 8
38
39 =item B<1>
40 Prevent the asterisk server from being overwhelmed by a large number of
41 Evergreen callfiles in the queue at once.
42
43 =item B<2>
44 Allow call window custom scheduling via crontab.  The guarantee is that
45 no more than queue_limit calls will be scheduled at the last scheduled run.
46
47 =back
48
49 By default no output is produced on successful operation.  Error conditions are
50 output, which should result in email to the system user via crontab.
51 Reads the same config file as the mediator, looks at the
52 staging directory for any pending callfiles.  If they exist, checks queue_limit
53
54 =head1 CONFIGURATION
55
56 See the eg-pbx-daemon.conf.  In particular, set use_allocator to 1 to indicate to
57 both processes (this one and the mediator) that the allocator is scheduled to run.
58
59 =head1 USAGE EXAMPLES
60
61 allocator.pl
62
63 allocator.pl -c /path/to/eg-pbx-daemon.conf
64
65 allocator.pl -t -c /some/other/config.txt
66
67 =head1 TODO
68
69 =over 8
70
71 =item LOAD TEST!!
72
73 =back
74
75 =head1 AUTHOR
76
77 Joe Atzberger,
78 Equinox Software, Inc.
79
80 =cut
81
82 package RevalidatorClient;
83
84 use strict;
85 use warnings;
86
87 use Sys::Syslog qw/:standard :macros/;
88 use RPC::XML;
89 use RPC::XML::Client;
90 use Data::Dumper;
91
92 sub new {
93     my $self = bless {}, shift;
94
95     $self->setup(@_);
96     return $self;
97 }
98
99 sub setup {
100     my ($self, %config) = @_;
101
102     # XXX error_handler, fault_handler, combined_handler
103     # such handlers should syslog and die
104
105     $self->{client} = new RPC::XML::Client($config{revalidator_uri});
106     $self->{config} = \%config;
107 }
108
109 sub get_event_ids {
110     my ($self, $filename) = @_;
111
112     if (not open FH, "<$filename") {
113         syslog LOG_ERR, "revalidator client could not open $filename";
114         die "revalidator client could not open $filename";
115     }
116
117     my $result = 0;
118     while (<FH>) {
119         next unless /event_ids = ([\d,]+)$/;
120
121         $result = [ map int, split(/,/, $1) ];
122     }
123
124     close FH;
125     return $result;
126 }
127
128 sub still_valid {
129     my ($self, $filename) = @_;
130     # Here we want to contact Evergreen's open-ils.trigger service and get
131     # a revalidation of the event described in a given file.
132     # We'll return 1 for valid, 0 for invalid.
133
134     my $event_ids = $self->get_event_ids($filename) or return 0;
135
136     print STDERR (Dumper($event_ids), "\n") if $self->{config}->{t};
137
138     my $valid_list = $self->{client}->simple_request(
139         "open__ils.justintime.events.revalidate", $event_ids
140     );
141
142     # NOTE: we require all events to be valid
143     return (scalar(@$valid_list) == scalar(@$event_ids)) ? 1 : 0;
144 }
145
146 1;
147
148 package main;
149
150 use warnings;
151 use strict;
152
153 use Config::General qw/ParseConfig/;
154 use Getopt::Std;
155 use Pod::Usage;
156 use File::Basename qw/basename fileparse/;
157 use File::Spec;
158 use Sys::Syslog qw/:standard :macros/;
159 use Cwd qw/getcwd/;
160
161 my %config;
162 my %opts = (
163     c => "/etc/eg-pbx-daemon.conf",
164     v => 0,
165     t => 0,
166 );
167 my $universal_prefix = 'EG';
168
169 sub load_config {
170     %config = ParseConfig($opts{c});
171     # validate
172     foreach my $opt (qw/staging_path spool_path/) {
173         if (not -d $config{$opt}) {
174             die $config{$opt} . " ($opt): no such directory";
175         }
176     }
177
178     if (!($config{owner} = getpwnam($config{owner})) > 0) {
179         die $config{owner} . ": invalid owner";
180     }
181
182     if (!($config{group} = getgrnam($config{group})) > 0) {
183         die $config{group} . ": invalid group";
184     }
185
186     if ($config{universal_prefix}) {
187         $universal_prefix = $config{universal_prefix};
188         $universal_prefix =~ /^\D/
189             or die "Config error: universal_prefix ($universal_prefix) must start with non-integer character";
190     }
191     unless ($config{use_allocator} or $opts{t}) {
192         die "use_allocator not enabled in config file (mediator thinks allocator is not in use).  " .
193             "Run in test mode (-t) or enable use_allocator config";
194     }
195 }
196
197 sub match_files {
198 # argument: directory to check for files (default cwd)
199 # returns: array of pathnames from a given dir
200     my $root = @_ ? shift : getcwd();
201     my $pathglob = "$root/${universal_prefix}*.call";
202     my @matches  = grep {-f $_} <${pathglob}>;    # don't use <$pathglob>, that looks like ref to HANDLE
203     $opts{v} and             print scalar(@matches) . " match(es) for path: $pathglob\n";
204     $opts{t} or syslog LOG_NOTICE, scalar(@matches) . " match(es) for path: $pathglob";
205     return @matches;
206 }
207
208 sub prefixer {
209     # guarantee universal prefix on string (but don't add it again)
210     my $string = @_ ? shift : '';
211     $string =~ /^$universal_prefix\_/ and return $string;
212     return $universal_prefix . '_' . $string;
213 }
214
215 sub queue {
216     my $stage_name = shift or return;
217     $opts{t} or chown($config{owner}, $config{group}, $stage_name) or warn "error changing $stage_name to $config{owner}:$config{group}: $!";
218
219     # if ($timestamp and $timestamp > 0) {
220     #     utime $timestamp, $timestamp, $stage_name or warn "error utime'ing $stage_name to $timestamp: $!";
221     # }
222     my $goodname = prefixer((fileparse($stage_name))[0]);
223     my $finalized_filename = File::Spec->catfile($config{spool_path}, $goodname);
224     my $msg = sprintf "%40s --> %s", $stage_name, $finalized_filename;
225     unless ($opts{t}) {
226         unless (rename $stage_name, $finalized_filename) {
227             print   STDERR  "$msg  FAILED: $!\n";
228             syslog LOG_ERR, "$msg  FAILED: $!";
229             return;
230         }
231         syslog LOG_NOTICE, $msg;
232     }
233     $opts{v} and print $msg . "\n";
234 }
235
236 sub lock_file_create {
237     if (not open FH, ">$config{lock_file}") {
238         syslog LOG_ERR, "could not create lock file $config{lock_file}: $!";
239         die "could not create lock file!";
240     }
241     print FH $$, "\n";
242     close FH;
243 }
244
245 sub lock_file_release {
246     if (not unlink $config{lock_file}) {
247         syslog LOG_ERR, "could not remove lock file $config{lock_file}: $!";
248         die "could not remove lock file";
249     }
250 }
251
252 sub lock_file_test {
253     if (open FH, $config{lock_file}) {
254         my $pid = <FH>;
255         chomp $pid;
256         close FH;
257
258         # process still running?
259         if (-d "/proc/$pid") {
260             syslog(
261                 LOG_ERR,
262                 "lock file present ($config{lock_file}), $pid still running"
263             );
264             die "lock file present!";
265         } else {
266             syslog(
267                 LOG_INFO,
268                 "lock file present ($config{lock_file}), but $pid no longer running"
269             );
270             lock_file_release;
271         }
272     } 
273 }
274
275 sub holiday_test {
276     if (exists $config{holidays}) {
277         my $now = time;
278
279         if (not open FH, "<" . $config{holidays}) {
280             syslog LOG_ERR, "could not open holidays file $config{holidays}: $!";
281             die "could not open holidays file $config{holidays}: $!";
282         }
283
284         while (<FH>) {
285             chomp;
286             my ($from, $to) = map(int, split(/,/));
287
288             if ($now >= $from && $now <= $to) {
289                 close FH;
290                 syslog LOG_NOTICE, "$config{holidays} says it's a holiday, so i'm quitting";
291                 exit 0;
292             }
293         }
294         close FH;
295     }
296 }
297
298 ###  MAIN  ###
299
300 getopts('htvc:', \%opts) or pod2usage(2);
301 pod2usage( -verbose => 2 ) if $opts{h};
302
303 $opts{t} and $opts{v} = 1;
304 $opts{t} and print "TEST MODE\n";
305 $opts{v} and print "verbose output ON\n";
306 load_config;    # dies on invalid/incomplete config
307 openlog basename($0), 'ndelay', LOG_USER;
308 lock_file_test;
309 holiday_test;
310
311 # there seems to be no potential die()ing or exit()ing after this, failures with the revalidator
312 # excepting failures with the revalidator
313 lock_file_create;
314
315 my $now = time;
316 # incoming files sorted by mtime (stat element 9): OLDEST first
317 my @incoming = sort {(stat($a))[9] <=> (stat($b))[9]} match_files($config{staging_path});
318 my @outgoing = match_files($config{spool_path});
319 my @future   = ();
320
321 my $raw_count = scalar @incoming;
322 for (my $i=0; $i<$raw_count; $i++) {
323     if ((stat($incoming[$i]))[9] - $now > 0 ) { # if this file is from the future, then so are the subsequent ones
324         @future = splice(@incoming,$i);         # i.e., take advantage of having sorted them already
325         last;
326     }
327 }
328
329 # note: elements of @future not currently used beyond counting them
330
331 my  $in_count = scalar @incoming;
332 my $out_count = scalar @outgoing;
333 my $limit     = $config{queue_limit} || 0;
334 my $available = 0;
335
336 my @actually  = ();
337
338 if ($limit) {
339     $available = $limit - $out_count;
340     if ($available == 0) {
341         $opts{t} or syslog LOG_NOTICE, "Queue is full ($limit)";
342     }
343
344     if ($config{revalidator_uri}) { # USE REVALIDATOR
345         # Take as many files from @incoming as it takes to fill up @actually
346         # with files whose contents describe still-valid events.
347
348         my $revalidator = new RevalidatorClient(%config, %opts);
349
350         for (my $i = 0; $i < $available; $i++) {
351             while (@incoming) {
352                 my $candidate = shift @incoming;
353
354                 if ($revalidator->still_valid($candidate)) {
355                     unshift @actually, $candidate;
356                     last;
357                 } else {
358                     my $newpath = ($config{done_path} || "/tmp") .
359                         "/SKIPPED_" . basename($candidate);
360
361                     if ($opts{t}) {
362                         print "rename $candidate $newpath\n";
363                     } else {
364                         rename($candidate, $newpath);
365                     }
366                 }
367             }
368         }
369     } else { # DON'T USE REVALIDATOR
370         if ($in_count > $available) {
371             # slice down to correct size
372             @actually = @incoming[0..($available-1)];
373         }
374     }
375 }
376
377 # XXX Even without a limit we could still filter by still_valid() in theory,
378 # but in practive the user should always use a limit.
379
380 if ($opts{v}) {
381      printf "incoming (total)   : %3d\n", $raw_count;
382      printf "incoming (future)  : %3d\n", scalar @future;
383      printf "incoming (active)  : %3d\n", $in_count;
384      printf "incoming (filtered): %3d\n", scalar @actually;
385      printf "queued already     : %3d\n", $out_count;
386      printf "queue_limit        : %3d\n", $limit;
387      printf "available spots    : %3s\n", ($limit ? $available : 'unlimited');
388 }
389
390 foreach (@actually) {
391     queue($_);
392 }
393
394 lock_file_release;
395
396 0;