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 use warnings;
  83 use strict;
  84
  85 use Config::General qw/ParseConfig/;
  86 use Getopt::Std;
  87 use Pod::Usage;
  88 use File::Basename qw/basename fileparse/;
  89 use File::Spec;
  90 use Sys::Syslog qw/:standard :macros/;
  91 use Cwd qw/getcwd/;
  92
  93 our %config;
  94 our %opts = (
  95     c => "/etc/eg-pbx-daemon.conf",
  96     v => 0,
  97     t => 0,
  98 );
  99 our $universal_prefix = 'EG';
 100
 101 sub load_config {
 102     %config = ParseConfig($opts{c});
 103     # validate
 104     foreach my $opt (qw/staging_path spool_path/) {
 105         if (not -d $config{$opt}) {
 106             die $config{$opt} . " ($opt): no such directory";
 107         }
 108     }
 109
 110     if (!($config{owner} = getpwnam($config{owner})) > 0) {
 111         die $config{owner} . ": invalid owner";
 112     }
 113
 114     if (!($config{group} = getgrnam($config{group})) > 0) {
 115         die $config{group} . ": invalid group";
 116     }
 117
 118     if ($config{universal_prefix}) {
 119         $universal_prefix = $config{universal_prefix};
 120         $universal_prefix =~ /^\D/
 121             or die "Config error: universal_prefix ($universal_prefix) must start with non-integer character";
 122     }
 123     unless ($config{use_allocator} or $opts{t}) {
 124         die "use_allocator not enabled in config file (mediator thinks allocator is not in use).  " .
 125             "Run in test mode (-t) or enable use_allocator config";
 126     }
 127 }
 128
 129 sub match_files {
 130 # argument: directory to check for files (default cwd)
 131 # returns: array of pathnames from a given dir
 132     my $root = @_ ? shift : getcwd();
 133     my $pathglob = "$root/${universal_prefix}*.call";
 134     my @matches  = grep {-f $_} <${pathglob}>;    # don't use <$pathglob>, that looks like ref to HANDLE
 135     $opts{v} and             print scalar(@matches) . " match(es) for path: $pathglob\n";
 136     $opts{t} or syslog LOG_NOTICE, scalar(@matches) . " match(es) for path: $pathglob";
 137     return @matches;
 138 }
 139
 140 sub prefixer {
 141     # guarantee universal prefix on string (but don't add it again)
 142     my $string = @_ ? shift : '';
 143     $string =~ /^$universal_prefix\_/ and return $string;
 144     return $universal_prefix . '_' . $string;
 145 }
 146
 147 sub queue {
 148     my $stage_name = shift or return;
 149     $opts{t} or chown($config{owner}, $config{group}, $stage_name) or warn "error changing $stage_name to $config{owner}:$config{group}: $!";
 150
 151     # if ($timestamp and $timestamp > 0) {
 152     #     utime $timestamp, $timestamp, $stage_name or warn "error utime'ing $stage_name to $timestamp: $!";
 153     # }
 154     my $goodname = prefixer((fileparse($stage_name))[0]);
 155     my $finalized_filename = File::Spec->catfile($config{spool_path}, $goodname);
 156     my $msg = sprintf "%40s --> %s", $stage_name, $finalized_filename;
 157     unless ($opts{t}) {
 158         unless (rename $stage_name, $finalized_filename) {
 159             print   STDERR  "$msg  FAILED: $!\n";
 160             syslog LOG_ERR, "$msg  FAILED: $!";
 161             return;
 162         }
 163         syslog LOG_NOTICE, $msg;
 164     }
 165     $opts{v} and print $msg . "\n";
 166 }
 167
 168 ###  MAIN  ###
 169
 170 getopts('htvc:', \%opts) or pod2usage(2);
 171 pod2usage( -verbose => 2 ) if $opts{h};
 172
 173 $opts{t} and $opts{v} = 1;
 174 $opts{t} and print "TEST MODE\n";
 175 $opts{v} and print "verbose output ON\n";
 176 load_config;    # dies on invalid/incomplete config
 177 openlog basename($0), 'ndelay', LOG_USER;
 178
 179 my $now = time;
 180 # incoming files sorted by mtime (stat element 9): OLDEST first
 181 my @incoming = sort {(stat($a))[9] <=> (stat($b))[9]} match_files($config{staging_path});
 182 my @outgoing = match_files($config{spool_path});
 183 my @future   = ();
 184
 185 my $raw_count = scalar @incoming;
 186 for (my $i=0; $i<$raw_count; $i++) {
 187     if ((stat($incoming[$i]))[9] - $now > 0 ) { # if this file is from the future, then so are the subsequent ones
 188         @future = splice(@incoming,$i);         # i.e., take advantage of having sorted them already
 189         last;
 190     }
 191 }
 192
 193 # note: elements of @future not currently used beyond counting them
 194
 195 my  $in_count = scalar @incoming;
 196 my $out_count = scalar @outgoing;
 197 my $limit     = $config{queue_limit} || 0;
 198 my $available = 0;
 199
 200 if ($limit) {
 201     $available = $limit - $out_count;
 202     if ($in_count > $available) {
 203         @incoming = @incoming[0..($available-1)];   # slice down to correct size
 204     }
 205     if ($available == 0) {
 206         $opts{t} or syslog LOG_NOTICE, "Queue is full ($limit)";
 207     }
 208 }
 209
 210 if ($opts{v}) {
 211      printf "incoming (total ): %3d\n", $raw_count;
 212      printf "incoming (future): %3d\n", scalar @future;
 213      printf "incoming (active): %3d\n", $in_count;
 214      printf "queued already   : %3d\n", $out_count;
 215      printf "queue_limit      : %3d\n", $limit;
 216      printf "available spots  : %3s\n", ($limit ? $available : 'unlimited');
 217 }
 218
 219 foreach (@incoming) {
 220     # $opts{v} and print `ls -l $_`;  # '  ', (stat($_))[9], " - $now = ", (stat($_))[9] - $now, "\n";
 221     queue($_);
 222 }
 223