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/) {
  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 inject {
 144     my ($data, $requested_filename, $timestamp) = @_;
 145 # Sender can specify filename: [PREFIX . '_' .] id_string1 . '_' . id_string2 [. '.' . time-serial . '.call']
 146 # TODO: overwrite based on id_strings, possibly controlled w/ extra arg?
 147
 148     my $ret = {
 149         code => 200,    # optimism
 150         use_allocator => $config{use_allocator},
 151     };
 152     my $fname;
 153     $requested_filename = fileparse($requested_filename || ''); # no fair trying to get us to write in other dirs
 154     if ($requested_filename and $requested_filename ne 'default') {
 155         # Check for possible replacement of files
 156         my ($userid, $noticetype) = replace_match_possible($requested_filename);
 157         $ret->{replace_match} = ($userid and $noticetype) ? 1 : 0;
 158         $ret->{userid}        = $userid     if $userid;
 159         $ret->{noticetype}    = $noticetype if $noticetype;
 160         if ($ret->{replace_match}) {
 161             my @hits = replace_match_files($userid, $noticetype);
 162             $ret->{replace_match_count} = scalar @hits;
 163             $ret->{replace_match_files} = join ',', map {$_=fileparse($_)} @hits;  # strip leading dirs from fullpaths
 164             my @fails = ();
 165             foreach (@hits) {
 166                 unlink and next;
 167                 (-f $_) and push @fails, (fileparse($_))[0] . ": $!";
 168                 # TODO: refactor to use cleanup() or core of cleanup?
 169                 # We check again for the file existing since it might *just* have been picked up and finished.
 170                 # In that case, too bad, the user is going to get our injected call soon also.
 171             }
 172             if (@fails) {
 173                 $ret->{replace_match_fails} = join ',', map {$_=fileparse($_)} @fails;  # strip leading dirs from fullpaths
 174                 syslog LOG_ERR, $_[0];
 175                 # BAIL OUT?  For now, we treat failure to overwrite matches as non-fatal
 176             }
 177             $data .= sprintf("; %d of %d queued files replaced\n", scalar(@hits) - scalar(@fails), scalar(@hits));
 178         }
 179         $fname = $requested_filename;
 180     } else {
 181         $fname = auto_filename;
 182     }
 183
 184     $fname = prefixer($fname);                  # guarantee universal prefix
 185     $fname =~ /\.call$/  or $fname .= '.call';  # guarantee .call suffix
 186
 187     my $stage_name         = $config{staging_path} . "/" . $fname;
 188     my $finalized_filename = $config{spool_path}   . "/" . $fname;
 189
 190     $data .= ";; added by inject() in the mediator\n";
 191     $data .= "Set: callfilename=$fname\n";
 192
 193     # And now, we're finally ready to begin the actual insertion process
 194     open  FH, ">$stage_name" or return &$failure("cannot open $stage_name: $!");
 195     print FH $data           or return &$failure("cannot write $stage_name: $!");
 196     close FH                 or return &$failure("cannot close $stage_name: $!");
 197
 198     chown($config{owner}, $config{group}, $stage_name) or
 199         return &$failure(
 200             "error changing $stage_name to $config{owner}:$config{group}: $!"
 201         );
 202
 203     if ($timestamp and $timestamp > 0) {
 204         utime $timestamp, $timestamp, $stage_name or
 205             return &$failure("error utime'ing $stage_name to $timestamp: $!");
 206     }
 207
 208     # note: EG doesn't have to care whether the spool is the "real" one or the allocator "pre" spool,
 209     #       so the filename is returned under the same key.  EG can check use_allocator though if it
 210     #       wants to know for sure.
 211
 212     if ($config{use_allocator}) {
 213         $ret->{spooled_filename} = $stage_name;
 214         syslog LOG_NOTICE, "Left $stage_name for allocator";
 215     } elsif (rename $stage_name, $finalized_filename) {     # else the rename happens here
 216         $ret->{spooled_filename} = $finalized_filename;
 217         syslog LOG_NOTICE, "Spooled $finalized_filename sucessfully";
 218     } else {
 219         syslog LOG_ERR,  "rename $stage_name ==> $finalized_filename: $!";
 220         return &$failure("rename $stage_name ==> $finalized_filename: $!");
 221     }
 222
 223     return $ret;
 224 }
 225
 226
 227 sub retrieve {
 228     my $globstring = prefixer(@_ ? shift : '*');
 229     # We depend on being in the correct (done) directory already, thanks to the config step
 230     # This prevents us from having to chdir for each request..
 231
 232     my @matches = grep {-f $_ } <'./' . ${globstring}>;    # don't use <$pathglob>, that looks like ref to HANDLE
 233
 234     my $ret = {
 235         code => 200,
 236         glob_used   => $globstring,
 237         match_count => scalar(@matches),
 238     };
 239     my $i = 0;
 240     foreach my $match (@matches) {
 241         $i++;
 242         # warn "file $i '$match'";
 243         unless (open (FILE, "<$match")) {
 244             syslog LOG_ERR, "Cannot read done file $i of " . scalar(@matches) . ": '$match'";
 245             $ret->{error_count}++;
 246             next;
 247         }
 248         my @content = <FILE>;   #slurpy
 249         close FILE;
 250
 251         $ret->{'file_' . sprintf("%06d",$i++)} = {
 252             filename => fileparse($match),
 253             content  => join('', @content),
 254         };
 255     }
 256     return $ret;
 257 }
 258
 259
 260 # cleanup: deletes files
 261 # arguments: string (comma separated filenames), optional int flag
 262 # returns: struct reporting success/failure
 263 #
 264 # The list of files to delete must be explicit, in a comma-separated string.
 265 # We cannot use globs or any other
 266 # pattern matching because there might be additional files that match.  Asterisk
 267 # might be making calls for other people and prodcesses (i.e., non-EG calls) or
 268 # might have made more calls for us since the last time we checked matches.
 269
 270 sub cleanup {
 271     my $targetstring = shift or return &$bad_request(
 272         "Must supply at least one filename to cleanup()"     # not empty string!
 273     );
 274     my $dequeue = @_ ? shift : 0;  # default is to target done files.
 275     my @targets = split ',', $targetstring;
 276     my $path = $dequeue ? $config{spool_path} : $config{done_path};
 277     (-r $path and -d $path) or return &$failure("Cannot open dir '$path': $!");
 278
 279     my $ret = {
 280         code => 200,    # optimism
 281         request_count => scalar(@targets),
 282         from_queue    => $dequeue,
 283         match_count   => 0,
 284         delete_count  => 0,
 285     };
 286
 287     my %problems;
 288     my $i = 0;
 289     foreach my $target (@targets) {
 290         $i++;
 291         $target = fileparse($target);    # no fair trying to get us to delete in other directories!
 292         my $file = $path . '/' . prefixer($target);
 293         unless (-f $file) {
 294             $problems{$target} = {
 295                 code => 404,        # NOT FOUND: may or may not be a true error, since our purpose was to delete it anyway.
 296                 target => $target,
 297             };
 298             syslog LOG_NOTICE, "Delete request $i of " . $ret->{request_count} . " for file '$file': File not found";
 299             next;
 300         }
 301
 302         $ret->{match_count}++;
 303         if (unlink $file) {
 304             $ret->{delete_count}++;
 305             syslog LOG_NOTICE, "Delete request $i of " . $ret->{request_count} . " for file '$file' successful";
 306         } else {
 307             syslog LOG_ERR,    "Delete request $i of " . $ret->{request_count} . " for file '$file' FAILED: $!";
 308             $problems{$target} = {
 309                 code => 403,        # FORBIDDEN: permissions problem
 310                 target => $target,
 311             };
 312             next;
 313         }
 314     }
 315
 316     my $prob_count = scalar keys %problems;
 317     if ($prob_count) {
 318         $ret->{error_count} = $prob_count;
 319         if ($prob_count == 1 and $ret->{request_count} == 1) {
 320              # We had exactly 1 error and no successes
 321             my $one = (values %problems)[0];
 322             $ret->{code} = $one->{code};     # So our code is the error's code
 323         } else {
 324             $ret->{code} = 207;              # otherwise, MULTI-STATUS
 325             $ret->{multistatus} = \%problems;
 326         }
 327     }
 328     return $ret;
 329 }
 330
 331
 332 sub main {
 333     getopt('c:', \%opts);
 334     load_config;    # dies on invalid/incomplete config
 335     openlog basename($0), 'ndelay', LOG_USER;
 336     my $server = RPC::XML::Server->new(port => $config{port}) or die "Failed to get new RPC::XML::Server: $!";
 337
 338     # Regarding signatures:
 339     #  ~ the first datatype  is  for RETURN value,
 340     #  ~ any other datatypes are for INCOMING args
 341     #
 342     # Everything here returns a struct.
 343
 344     $server->add_proc({
 345         name => 'inject',   code => \&inject,   signature => ['struct string', 'struct string string', 'struct string string int']
 346     });
 347     $server->add_proc({
 348         name => 'retrieve', code => \&retrieve, signature => ['struct string', 'struct']
 349     });
 350     $server->add_proc({
 351         name => 'cleanup',  code => \&cleanup,  signature => ['struct string', 'struct string int']
 352     });
 353
 354     $server->add_default_methods;
 355     $server->server_loop;
 356     0;
 357 }
 358
 359 exit main @ARGV;    # do it all!