3 # Copyright (C) 2009 Equinox Software, Inc.
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.
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.
24 allocator.pl [-h] [-t] [-v] [-c <file>]
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
34 This script is designed to run from crontab on a very frequent basis, perhaps
35 every minute. It has two purposes:
40 Prevent the asterisk server from being overwhelmed by a large number of
41 Evergreen callfiles in the queue at once.
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.
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
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.
63 allocator.pl -c /path/to/eg-pbx-daemon.conf
65 allocator.pl -t -c /some/other/config.txt
78 Equinox Software, Inc.
82 package RevalidatorClient;
84 use Sys::Syslog qw/:standard :macros/;
90 my $self = bless {}, shift;
97 my ($self, %config) = @_;
99 # XXX error_handler, fault_handler, combined_handler
100 # such handlers should syslog and die
102 $self->{client} = new RPC::XML::Client($config{revalidator_uri});
103 $self->{config} = \%config;
107 my ($self, $filename) = @_;
109 if (not open FH, "<$filename") {
110 syslog LOG_ERR, "revalidator client could not open $filename";
111 die "revalidator client could not open $filename";
116 next unless /event_ids = ([\d,]+)$/;
118 $result = [ map int, split(/,/, $1) ];
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.
131 my $event_ids = $self->get_event_ids($filename) or return 0;
133 print STDERR (Dumper($event_ids), "\n") if $self->{config}->{t};
135 my $valid_list = $self->{client}->simple_request(
136 "open-ils.justintime.events.revalidate", $event_ids
139 # NOTE: we require all events to be valid
140 return (scalar(@$valid_list) == scalar(@$event_ids)) ? 1 : 0;
150 use Config::General qw/ParseConfig/;
153 use File::Basename qw/basename fileparse/;
155 use Sys::Syslog qw/:standard :macros/;
160 c => "/etc/eg-pbx-daemon.conf",
164 my $universal_prefix = 'EG';
167 %config = ParseConfig($opts{c});
169 foreach my $opt (qw/staging_path spool_path/) {
170 if (not -d $config{$opt}) {
171 die $config{$opt} . " ($opt): no such directory";
175 if (!($config{owner} = getpwnam($config{owner})) > 0) {
176 die $config{owner} . ": invalid owner";
179 if (!($config{group} = getgrnam($config{group})) > 0) {
180 die $config{group} . ": invalid group";
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";
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";
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";
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;
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}: $!";
216 # if ($timestamp and $timestamp > 0) {
217 # utime $timestamp, $timestamp, $stage_name or warn "error utime'ing $stage_name to $timestamp: $!";
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;
223 unless (rename $stage_name, $finalized_filename) {
224 print STDERR "$msg FAILED: $!\n";
225 syslog LOG_ERR, "$msg FAILED: $!";
228 syslog LOG_NOTICE, $msg;
230 $opts{v} and print $msg . "\n";
235 getopts('htvc:', \%opts) or pod2usage(2);
236 pod2usage( -verbose => 2 ) if $opts{h};
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;
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});
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
258 # note: elements of @future not currently used beyond counting them
260 my $in_count = scalar @incoming;
261 my $out_count = scalar @outgoing;
262 my $limit = $config{queue_limit} || 0;
268 $available = $limit - $out_count;
269 if ($available == 0) {
270 $opts{t} or syslog LOG_NOTICE, "Queue is full ($limit)";
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.
277 my $revalidator = new RevalidatorClient(%config, %opts);
279 for (my $i = 0; $i < $available; $i++) {
281 my $candidate = shift @incoming;
283 if ($revalidator->still_valid($candidate)) {
284 unshift @actually, $candidate;
287 my $newpath = ($config{done_path} || "/tmp") .
288 "/SKIPPED_" . basename($candidate);
291 print "rename $candidate $newpath\n";
293 rename($candidate, $newpath);
298 } else { # DON'T USE REVALIDATOR
299 if ($in_count > $available) {
300 # slice down to correct size
301 @actually = @incoming[0..($available-1)];
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.
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');
319 foreach (@actually) {
320 # $opts{v} and print `ls -l $_`; # ' ', (stat($_))[9], " - $now = ", (stat($_))[9] - $now, "\n";