Open-ILS/src/asterisk/pbx-daemon/eg-pbx-mediator.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # Copyright (C) 2009 Equinox Software, Inc.
   4 # Author: Lebbeous Fogle-Weekley
   5 # Author: Joe Atzberger
   6 #
   7 # License:
   8 #
   9 # This program is free software; you can redistribute it and/or
  10 # modify it under the terms of the GNU General Public License
  11 # as published by the Free Software Foundation; either version 2
  12 # of the License, or (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # Overview:
  20 #
  21 #   This script is to be used on an asterisk server as an RPC::XML
  22 #   daemon targeted by Evergreen.
  23 #
  24 # Configuration:
  25 #
  26 #   See the eg-pbx-daemon.conf and extensions.conf.example files.
  27 #
  28 # Usage:
  29 #
  30 #   perl mediator.pl -c /path/to/eg-pbx-daemon.conf
  31 #
  32 # TODO:
  33 #
  34 # ~ Server retrieval of done files.
  35 # ~ Option to archive (/etc/asterisk/spool/outgoing_really_done) instead of delete?
  36 # ~ Accept globby prefix for filtering files to be retrieved.
  37 # ~ init.d startup/shutdown/status script.
  38 # ~ More docs.
  39 # ~ perldoc/POD
  40 # - command line usage and --help
  41 #
  42
  43 use warnings;
  44 use strict;
  45
  46 use RPC::XML::Server;
  47 use Config::General qw/ParseConfig/;
  48 use Getopt::Std;
  49 use File::Basename qw/basename fileparse/;
  50 use Sys::Syslog qw/:standard :macros/;
  51
  52 our %config;
  53 our %opts = (c => "/etc/eg-pbx-daemon.conf");
  54 our $last_n = 0;
  55 our $universal_prefix = 'EG';
  56
  57 my $failure = sub {
  58     syslog LOG_ERR, $_[0];
  59
  60     return new RPC::XML::fault(
  61         faultCode => 500,
  62         faultString => $_[0])
  63 };
  64
  65 my $bad_request = sub {
  66     syslog LOG_WARNING, $_[0];
  67
  68     return new RPC::XML::fault(
  69         faultCode => 400,
  70         faultString => $_[0])
  71 };
  72
  73 sub load_config {
  74     %config = ParseConfig($opts{c});
  75
  76     # validate
  77     foreach my $opt (qw/staging_path spool_path done_path ack_path/) {
  78         if (not -d $config{$opt}) {
  79             die $config{$opt} . " ($opt): no such directory";
  80         }
  81     }
  82
  83     if ($config{port} < 1 || $config{port} > 65535) {
  84         die $config{port} . ": not a valid port number";
  85     }
  86
  87     if (!($config{owner} = getpwnam($config{owner})) > 0) {
  88         die $config{owner} . ": invalid owner";
  89     }
  90
  91     if (!($config{group} = getgrnam($config{group})) > 0) {
  92         die $config{group} . ": invalid group";
  93     }
  94
  95     my $path = $config{done_path};
  96     (chdir $path) or die "Cannot open dir '$path': $!";
  97
  98     if ($config{universal_prefix}) {
  99         $universal_prefix = $config{universal_prefix};
 100         $universal_prefix =~ /^\D/
 101             or die "Config error: universal_prefix ($universal_prefix) must start with non-integer character";
 102     }
 103 }
 104
 105 sub replace_match_possible {
 106 # arguments: a string (requested_filename), parsed to see if it has the necessary
 107 #            components to use for finding possible queued callfiles to delete
 108 # returns: (userid, $noticetype) if either or both is found, else undef;
 109     my $breakdown = shift or return;
 110     $breakdown =~ s/\..*$//;    # cut everything at the 1st period
 111     $breakdown =~ /([^_]*)_([^_]*)$/ or return;
 112     return ($1, $2);
 113 }
 114
 115 sub replace_match_files {
 116 # arguments: (id_string1, id_string2)
 117 # returns: array of pathnames (files to be deleted)
 118 # currently we will only find at most 1 file to replace,
 119 # but you can see how this could be extended w/ additional namespace and globbing
 120     my $userid     = shift or return;   # doesn't have to be userid,     could be any ID string
 121     my $noticetype = shift or return;   # doesn't have to be noticetype, could be any extra dimension of uniqueness
 122     my $pathglob   = $config{spool_path} . "/" . compose_filename($userid, $noticetype);
 123     # my $pathglob = $config{spool_path} . "/$universal_prefix" . "_$userid" . "_$noticetype" . '*.call';
 124     my @matches    = grep {-f $_} <${pathglob}>;    # don't use <$pathglob>, that looks like ref to HANDLE
 125     warn               scalar(@matches) . " match(es) for path: $pathglob";
 126     syslog LOG_NOTICE, scalar(@matches) . " match(es) for path: $pathglob";
 127     return @matches;
 128 }
 129
 130 sub compose_filename {
 131     return sprintf "%s_%s_%s.call", $universal_prefix, (@_?shift:''), (@_?shift:'');
 132 }
 133 sub auto_filename {
 134     return sprintf("%s_%d-%05d.call", $universal_prefix, time, $last_n++);
 135 }
 136 sub prefixer {
 137     # guarantee universal prefix on string (but don't add it again)
 138     my $string = @_ ? shift : '';
 139     $string =~ /^$universal_prefix\_/ and return $string;
 140     return $universal_prefix . '_' . $string;
 141 }
 142
 143 sub get_status_from_callfile {
 144     my ($filename) = @_;
 145
 146     if (not open FH, "<$filename") {
 147         syslog(LOG_ERR, "error opening $filename: $!");
 148         return;
 149     }
 150
 151     my @event_ids;
 152
 153     while(<FH>) {
 154         # The AstCall A/T reactor puts this line into all call files.
 155         next unless /^; event_ids = ([\d\,]+)$/;
 156         push @event_ids, map(int, split(/,/, $1));
 157         last;
 158     }
 159
 160     seek(FH, -64, 2);   # go to end of file. back up enough to read short line.
 161     my @lines = <FH>;
 162     close FH;
 163
 164     my $status;
 165     if (my $lastline = pop @lines) {    # sic, assignment
 166         $status = $1 if $lastline =~ /^Status: (\w+)$/;
 167     }
 168
 169     return ($status, @event_ids);
 170 }
 171
 172 sub ack_callfile {
 173     my ($basename) = @_;
 174     my $from = $config{done_path} . '/' . $basename;
 175     my $to = $config{ack_path} . '/' . $basename;
 176
 177     if (not rename($from, $to)) {
 178         syslog LOG_ERR, "ack_callfile() could not move '$from' to '$to'";
 179         return 0;
 180     } else {
 181         return 1;
 182     }
 183 }
 184
 185 # Returns a list of event ids from files in the done_path that don't end in
 186 # Status: Completed (which is what Asterisk will put there if it thinks somebody
 187 # answered the call).
 188 #
 189 # The optional argument $with_filenames is for internal use by ack_failures().
 190 #
 191 sub get_failures {
 192     my ($with_filenames) = @_;
 193
 194     if (not opendir DIR, $config{done_path}) {
 195         syslog LOG_ERR, "could not opendir $config{done_path}: $!";
 196         return [];
 197     }
 198
 199     my @files = grep { /^${universal_prefix}.+\.call$/ } readdir DIR;
 200     closedir DIR;
 201
 202     my %result_tree;
 203     my @result_set;
 204     no warnings 'uninitialized';
 205
 206     foreach my $filename (@files) {
 207         my ($status, @event_ids) =
 208             get_status_from_callfile($config{done_path} . '/' . $filename);
 209
 210         if ($status ne 'Completed') {
 211             if ($with_filenames) {
 212                 $result_tree{$filename} = [@event_ids];
 213             } else {
 214                 push @result_set, @event_ids;
 215             }
 216         }
 217     }
 218
 219     return ($with_filenames ? \%result_tree : \@result_set);
 220 }
 221
 222 # Given a list of event ids, finds calls files in the done_path that refer to
 223 # them, and moves any such files to the ack_path directory.
 224 #
 225 # Returns the number of files archived for informational purposes only.
 226 #
 227 sub ack_failures {
 228     my @event_ids = map(int, (grep defined, @{shift()}));
 229
 230     my %lookup = map { $_ => 1 } @event_ids;
 231
 232     my $known_failures = get_failures(1);  # 1 means "with filenames"
 233     my $archived = 0;
 234
 235     OUTER: foreach my $filename (keys(%$known_failures)) {
 236         my @ids_known_failed = @{ $known_failures->{$filename} };
 237         foreach (@ids_known_failed) {
 238             next OUTER unless exists $lookup{$_};
 239         }
 240         $archived += ack_callfile($filename);
 241     }
 242
 243     return $archived;
 244 }
 245
 246 sub set_holidays {
 247     my ($holidays) = @_;
 248
 249     return -1 unless exists $config{holidays};
 250     return -2 unless @$holidays <= $config{holiday_limit};
 251
 252     if (-e $config{holidays}) {
 253         rename($config{holidays}, $config{holidays} . ".bak") or return -3;
 254     }
 255
 256     my $count = 0;
 257     open HOLIDAYS, ">$config{holidays}" or return -4;
 258
 259     foreach (@$holidays) {
 260         next unless @$_ == 2;
 261
 262         print HOLIDAYS sprintf("%d,%d\n", @$_);
 263         $count++;
 264     }
 265     close HOLIDAYS;
 266
 267     return $count;
 268 }
 269
 270 sub inject {
 271     my ($data, $requested_filename, $timestamp) = @_;
 272 # Sender can specify filename: [PREFIX . '_' .] id_string1 . '_' . id_string2 [. '.' . time-serial . '.call']
 273 # TODO: overwrite based on id_strings, possibly controlled w/ extra arg?
 274
 275     my $ret = {
 276         code => 200,    # optimism
 277         use_allocator => $config{use_allocator},
 278     };
 279     my $fname;
 280     $requested_filename = fileparse($requested_filename || ''); # no fair trying to get us to write in other dirs
 281     if ($requested_filename and $requested_filename ne 'default') {
 282         # Check for possible replacement of files
 283         my ($userid, $noticetype) = replace_match_possible($requested_filename);
 284         $ret->{replace_match} = ($userid and $noticetype) ? 1 : 0;
 285         $ret->{userid}        = $userid     if $userid;
 286         $ret->{noticetype}    = $noticetype if $noticetype;
 287         if ($ret->{replace_match}) {
 288             my @hits = replace_match_files($userid, $noticetype);
 289             $ret->{replace_match_count} = scalar @hits;
 290             $ret->{replace_match_files} = join ',', map {$_=fileparse($_)} @hits;  # strip leading dirs from fullpaths
 291             my @fails = ();
 292             foreach (@hits) {
 293                 unlink and next;
 294                 (-f $_) and push @fails, (fileparse($_))[0] . ": $!";
 295                 # TODO: refactor to use cleanup() or core of cleanup?
 296                 # We check again for the file existing since it might *just* have been picked up and finished.
 297                 # In that case, too bad, the user is going to get our injected call soon also.
 298             }
 299             if (@fails) {
 300                 $ret->{replace_match_fails} = join ',', map {$_=fileparse($_)} @fails;  # strip leading dirs from fullpaths
 301                 syslog LOG_ERR, $_[0];
 302                 # BAIL OUT?  For now, we treat failure to overwrite matches as non-fatal
 303             }
 304             $data .= sprintf("; %d of %d queued files replaced\n", scalar(@hits) - scalar(@fails), scalar(@hits));
 305         }
 306         $fname = $requested_filename;
 307     } else {
 308         $fname = auto_filename;
 309     }
 310
 311     $fname = prefixer($fname);                  # guarantee universal prefix
 312     $fname =~ /\.call$/  or $fname .= '.call';  # guarantee .call suffix
 313
 314     my $stage_name         = $config{staging_path} . "/" . $fname;
 315     my $finalized_filename = $config{spool_path}   . "/" . $fname;
 316
 317     $data .= ";; added by inject() in the mediator\n";
 318     $data .= "Set: callfilename=$fname\n";
 319
 320     # And now, we're finally ready to begin the actual insertion process
 321     open  FH, ">$stage_name" or return &$failure("cannot open $stage_name: $!");
 322     print FH $data           or return &$failure("cannot write $stage_name: $!");
 323     close FH                 or return &$failure("cannot close $stage_name: $!");
 324
 325     chown($config{owner}, $config{group}, $stage_name) or
 326         return &$failure(
 327             "error changing $stage_name to $config{owner}:$config{group}: $!"
 328         );
 329
 330     if ($timestamp and $timestamp > 0) {
 331         utime $timestamp, $timestamp, $stage_name or
 332             return &$failure("error utime'ing $stage_name to $timestamp: $!");
 333     }
 334
 335     # note: EG doesn't have to care whether the spool is the "real" one or the allocator "pre" spool,
 336     #       so the filename is returned under the same key.  EG can check use_allocator though if it
 337     #       wants to know for sure.
 338
 339     if ($config{use_allocator}) {
 340         $ret->{spooled_filename} = $stage_name;
 341         syslog LOG_NOTICE, "Left $stage_name for allocator";
 342     } elsif (rename $stage_name, $finalized_filename) {     # else the rename happens here
 343         $ret->{spooled_filename} = $finalized_filename;
 344         syslog LOG_NOTICE, "Spooled $finalized_filename sucessfully";
 345     } else {
 346         syslog LOG_ERR,  "rename $stage_name ==> $finalized_filename: $!";
 347         return &$failure("rename $stage_name ==> $finalized_filename: $!");
 348     }
 349
 350     return $ret;
 351 }
 352
 353
 354 sub main {
 355     getopt('c:', \%opts);
 356     load_config;    # dies on invalid/incomplete config
 357     openlog basename($0), 'ndelay', LOG_USER;
 358     my $server = RPC::XML::Server->new(port => $config{port}) or die "Failed to get new RPC::XML::Server: $!";
 359
 360     # Regarding signatures:
 361     #  ~ the first datatype  is  for RETURN value,
 362     #  ~ any other datatypes are for INCOMING args
 363     #
 364
 365     $server->add_proc({
 366         name => 'inject',   code => \&inject,   signature => ['struct string', 'struct string string', 'struct string string int']
 367     });
 368
 369     $server->add_proc({
 370         name => 'get_failures',
 371         code => \&get_failures,
 372         signature => ['array']
 373     });
 374
 375     $server->add_proc({
 376         name => 'ack_failures',
 377         code => \&ack_failures,
 378         signature => ['int array']
 379     });
 380
 381     $server->add_proc({
 382         name => 'set_holidays',
 383         code => \&set_holidays,
 384         signature => ['int array']
 385     });
 386
 387     $server->add_default_methods;
 388     $server->server_loop;
 389     0;
 390 }
 391
 392 exit main @ARGV;    # do it all!