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 = <>;
 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;