54af53522acdc8a81b1d42b7ee309a3466be043c
[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 Sys::Syslog qw/:standard :macros/;
85 use RPC::XML;
86 use RPC::XML::Client;
87 use Data::Dumper;
88
89 sub new {
90     my $self = bless {}, shift;
91
92     $self->setup(@_);
93     return $self;
94 }
95
96 sub setup {
97     my ($self, %config) = @_;
98
99     # XXX error_handler, fault_handler, combined_handler
100     # such handlers should syslog and die
101
102     $self->{client} = new RPC::XML::Client($config{revalidator_uri});
103     $self->{config} = \%config;
104 }
105
106 sub get_event_ids {
107     my ($self, $filename) = @_;
108
109     if (not open FH, "<$filename") {
110         syslog LOG_ERR, "revalidator client could not open $filename";
111         die "revalidator client could not open $filename";
112     }
113
114     my $result = 0;
115     while (<FH>) {
116         next unless /event_ids = ([\d,]+)$/;
117
118         $result = [ map int, split(/,/, $1) ];
119     }
120
121     close FH;
122     return $result;
123 }
124
125 sub still_valid {
126     my ($self, $filename) = @_;
127     # Here we want to contact Evergreen's open-ils.trigger service and get
128     # a revalidation of the event described in a given file.
129     # We'll return 1 for valid, 0 for invalid.
130
131     my $event_ids = $self->get_event_ids($filename) or return 0;
132
133     print STDERR (Dumper($event_ids), "\n") if $self->{config}->{t};
134
135     my $valid_list = $self->{client}->simple_request(
136         "open-ils.justintime.events.revalidate", $event_ids
137     );
138
139     # NOTE: we require all events to be valid
140     return (scalar(@$valid_list) == scalar(@$event_ids)) ? 1 : 0;
141 }
142
143 1;
144
145 package main;
146
147 use warnings;
148 use strict;
149
150 use Config::General qw/ParseConfig/;
151 use Getopt::Std;
152 use Pod::Usage;
153 use File::Basename qw/basename fileparse/;
154 use File::Spec;
155 use Sys::Syslog qw/:standard :macros/;
156 use Cwd qw/getcwd/;
157
158 my %config;
159 my %opts = (
160     c => "/etc/eg-pbx-daemon.conf",
161     v => 0,
162     t => 0,
163 );
164 my $universal_prefix = 'EG';
165
166 sub load_config {
167     %config = ParseConfig($opts{c});
168     # validate
169     foreach my $opt (qw/staging_path spool_path/) {
170         if (not -d $config{$opt}) {
171             die $config{$opt} . " ($opt): no such directory";
172         }
173     }
174
175     if (!($config{owner} = getpwnam($config{owner})) > 0) {
176         die $config{owner} . ": invalid owner";
177     }
178
179     if (!($config{group} = getgrnam($config{group})) > 0) {
180         die $config{group} . ": invalid group";
181     }
182
183     if ($config{universal_prefix}) {
184         $universal_prefix = $config{universal_prefix};
185         $universal_prefix =~ /^\D/
186             or die "Config error: universal_prefix ($universal_prefix) must start with non-integer character";
187     }
188     unless ($config{use_allocator} or $opts{t}) {
189         die "use_allocator not enabled in config file (mediator thinks allocator is not in use).  " .
190             "Run in test mode (-t) or enable use_allocator config";
191     }
192 }
193
194 sub match_files {
195 # argument: directory to check for files (default cwd)
196 # returns: array of pathnames from a given dir
197     my $root = @_ ? shift : getcwd();
198     my $pathglob = "$root/${universal_prefix}*.call";
199     my @matches  = grep {-f $_} <${pathglob}>;    # don't use <$pathglob>, that looks like ref to HANDLE
200     $opts{v} and             print scalar(@matches) . " match(es) for path: $pathglob\n";
201     $opts{t} or syslog LOG_NOTICE, scalar(@matches) . " match(es) for path: $pathglob";
202     return @matches;
203 }
204
205 sub prefixer {
206     # guarantee universal prefix on string (but don't add it again)
207     my $string = @_ ? shift : '';
208     $string =~ /^$universal_prefix\_/ and return $string;
209     return $universal_prefix . '_' . $string;
210 }
211
212 sub queue {
213     my $stage_name = shift or return;
214     $opts{t} or chown($config{owner}, $config{group}, $stage_name) or warn "error changing $stage_name to $config{owner}:$config{group}: $!";
215
216     # if ($timestamp and $timestamp > 0) {
217     #     utime $timestamp, $timestamp, $stage_name or warn "error utime'ing $stage_name to $timestamp: $!";
218     # }
219     my $goodname = prefixer((fileparse($stage_name))[0]);
220     my $finalized_filename = File::Spec->catfile($config{spool_path}, $goodname);
221     my $msg = sprintf "%40s --> %s", $stage_name, $finalized_filename;
222     unless ($opts{t}) {
223         unless (rename $stage_name, $finalized_filename) {
224             print   STDERR  "$msg  FAILED: $!\n";
225             syslog LOG_ERR, "$msg  FAILED: $!";
226             return;
227         }
228         syslog LOG_NOTICE, $msg;
229     }
230     $opts{v} and print $msg . "\n";
231 }
232
233 ###  MAIN  ###
234
235 getopts('htvc:', \%opts) or pod2usage(2);
236 pod2usage( -verbose => 2 ) if $opts{h};
237
238 $opts{t} and $opts{v} = 1;
239 $opts{t} and print "TEST MODE\n";
240 $opts{v} and print "verbose output ON\n";
241 load_config;    # dies on invalid/incomplete config
242 openlog basename($0), 'ndelay', LOG_USER;
243
244 my $now = time;
245 # incoming files sorted by mtime (stat element 9): OLDEST first
246 my @incoming = sort {(stat($a))[9] <=> (stat($b))[9]} match_files($config{staging_path});
247 my @outgoing = match_files($config{spool_path});
248 my @future   = ();
249
250 my $raw_count = scalar @incoming;
251 for (my $i=0; $i<$raw_count; $i++) {
252     if ((stat($incoming[$i]))[9] - $now > 0 ) { # if this file is from the future, then so are the subsequent ones
253         @future = splice(@incoming,$i);         # i.e., take advantage of having sorted them already
254         last;
255     }
256 }
257
258 # note: elements of @future not currently used beyond counting them
259
260 my  $in_count = scalar @incoming;
261 my $out_count = scalar @outgoing;
262 my $limit     = $config{queue_limit} || 0;
263 my $available = 0;
264
265 my @actually  = ();
266
267 if ($limit) {
268     $available = $limit - $out_count;
269     if ($available == 0) {
270         $opts{t} or syslog LOG_NOTICE, "Queue is full ($limit)";
271     }
272
273     if ($config{revalidator_uri}) { # USE REVALIDATOR
274         # Take as many files from @incoming as it takes to fill up @actually
275         # with files whose contents describe still-valid events.
276
277         my $revalidator = new RevalidatorClient(%config, %opts);
278
279         for (my $i = 0; $i < $available; $i++) {
280             while (@incoming) {
281                 my $candidate = shift @incoming;
282
283                 if ($revalidator->still_valid($candidate)) {
284                     unshift @actually, $candidate;
285                     last;
286                 } else {
287                     my $newpath = ($config{done_path} || "/tmp") .
288                         "/SKIPPED_" . basename($candidate);
289
290                     if ($opts{t}) {
291                         print "rename $candidate $newpath\n";
292                     } else {
293                         rename($candidate, $newpath);
294                     }
295                 }
296             }
297         }
298     } else { # DON'T USE REVALIDATOR
299         if ($in_count > $available) {
300             # slice down to correct size
301             @actually = @incoming[0..($available-1)];
302         }
303     }
304 }
305
306 # XXX Even without a limit we could still filter by still_valid() in theory,
307 # but in practive the user should always use a limit.
308
309 if ($opts{v}) {
310      printf "incoming (total)   : %3d\n", $raw_count;
311      printf "incoming (future)  : %3d\n", scalar @future;
312      printf "incoming (active)  : %3d\n", $in_count;
313      printf "incoming (filtered): %3d\n", scalar @actually;
314      printf "queued already     : %3d\n", $out_count;
315      printf "queue_limit        : %3d\n", $limit;
316      printf "available spots    : %3s\n", ($limit ? $available : 'unlimited');
317 }
318
319 foreach (@actually) {
320     # $opts{v} and print `ls -l $_`;  # '  ', (stat($_))[9], " - $now = ", (stat($_))[9] - $now, "\n";
321     queue($_);
322 }
323
324 1;