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;