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;
87 use Sys::Syslog qw/:standard :macros/;
93 my $self = bless {}, shift;
100 my ($self, %config) = @_;
102 # XXX error_handler, fault_handler, combined_handler
103 # such handlers should syslog and die
105 $self->{client} = new RPC::XML::Client($config{revalidator_uri});
106 $self->{config} = \%config;
110 my ($self, $filename) = @_;
112 if (not open FH, "<$filename") {
113 syslog LOG_ERR, "revalidator client could not open $filename";
114 die "revalidator client could not open $filename";
119 next unless /event_ids = ([\d,]+)$/;
121 $result = [ map int, split(/,/, $1) ];
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.
134 my $event_ids = $self->get_event_ids($filename) or return 0;
136 print STDERR (Dumper($event_ids), "\n") if $self->{config}->{t};
138 my $valid_list = $self->{client}->simple_request(
139 "open__ils.justintime.events.revalidate", $event_ids
142 # NOTE: we require all events to be valid
143 return (scalar(@$valid_list) == scalar(@$event_ids)) ? 1 : 0;
153 use Config::General qw/ParseConfig/;
156 use File::Basename qw/basename fileparse/;
158 use Sys::Syslog qw/:standard :macros/;
163 c => "/etc/eg-pbx-daemon.conf",
167 my $universal_prefix = 'EG';
170 %config = ParseConfig($opts{c});
172 foreach my $opt (qw/staging_path spool_path/) {
173 if (not -d $config{$opt}) {
174 die $config{$opt} . " ($opt): no such directory";
178 if (!($config{owner} = getpwnam($config{owner})) > 0) {
179 die $config{owner} . ": invalid owner";
182 if (!($config{group} = getgrnam($config{group})) > 0) {
183 die $config{group} . ": invalid group";
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";
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";
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";
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;
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}: $!";
219 # if ($timestamp and $timestamp > 0) {
220 # utime $timestamp, $timestamp, $stage_name or warn "error utime'ing $stage_name to $timestamp: $!";
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;
226 unless (rename $stage_name, $finalized_filename) {
227 print STDERR "$msg FAILED: $!\n";
228 syslog LOG_ERR, "$msg FAILED: $!";
231 syslog LOG_NOTICE, $msg;
233 $opts{v} and print $msg . "\n";
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!";
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";
253 if (open FH, $config{lock_file}) {
258 # process still running?
259 if (-d "/proc/$pid") {
262 "lock file present ($config{lock_file}), $pid still running"
264 die "lock file present!";
268 "lock file present ($config{lock_file}), but $pid no longer running"
276 if (exists $config{holidays}) {
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}: $!";
286 my ($from, $to) = map(int, split(/,/));
288 if ($now >= $from && $now <= $to) {
290 syslog LOG_NOTICE, "$config{holidays} says it's a holiday, so i'm quitting";
300 getopts('htvc:', \%opts) or pod2usage(2);
301 pod2usage( -verbose => 2 ) if $opts{h};
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;
311 # there seems to be no potential die()ing or exit()ing after this, failures with the revalidator
312 # excepting failures with the revalidator
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});
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
329 # note: elements of @future not currently used beyond counting them
331 my $in_count = scalar @incoming;
332 my $out_count = scalar @outgoing;
333 my $limit = $config{queue_limit} || 0;
339 $available = $limit - $out_count;
340 if ($available == 0) {
341 $opts{t} or syslog LOG_NOTICE, "Queue is full ($limit)";
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.
348 my $revalidator = new RevalidatorClient(%config, %opts);
350 for (my $i = 0; $i < $available; $i++) {
352 my $candidate = shift @incoming;
354 if ($revalidator->still_valid($candidate)) {
355 unshift @actually, $candidate;
358 my $newpath = ($config{done_path} || "/tmp") .
359 "/SKIPPED_" . basename($candidate);
362 print "rename $candidate $newpath\n";
364 rename($candidate, $newpath);
369 } else { # DON'T USE REVALIDATOR
370 if ($in_count > $available) {
371 # slice down to correct size
372 @actually = @incoming[0..($available-1)];
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.
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');
390 foreach (@actually) {