3 # Copyright (C) 2009 Equinox Software, Inc.
4 # Author: Lebbeous Fogle-Weekley
5 # Author: Joe Atzberger
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.
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.
21 # This script is to be used on an asterisk server as an RPC::XML
22 # daemon targeted by Evergreen.
26 # See the eg-pbx-daemon.conf and extensions.conf.example files.
30 # perl mediator.pl -c /path/to/eg-pbx-daemon.conf
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.
40 # - command line usage and --help
47 use Config::General qw/ParseConfig/;
49 use File::Basename qw/basename fileparse/;
50 use Sys::Syslog qw/:standard :macros/;
53 our %opts = (c => "/etc/eg-pbx-daemon.conf");
55 our $universal_prefix = 'EG';
58 syslog LOG_ERR, $_[0];
60 return new RPC::XML::fault(
65 my $bad_request = sub {
66 syslog LOG_WARNING, $_[0];
68 return new RPC::XML::fault(
74 %config = ParseConfig($opts{c});
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";
83 if ($config{port} < 1 || $config{port} > 65535) {
84 die $config{port} . ": not a valid port number";
87 if (!($config{owner} = getpwnam($config{owner})) > 0) {
88 die $config{owner} . ": invalid owner";
91 if (!($config{group} = getgrnam($config{group})) > 0) {
92 die $config{group} . ": invalid group";
95 my $path = $config{done_path};
96 (chdir $path) or die "Cannot open dir '$path': $!";
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";
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;
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";
130 sub compose_filename {
131 return sprintf "%s_%s_%s.call", $universal_prefix, (@_?shift:''), (@_?shift:'');
134 return sprintf("%s_%d-%05d.call", $universal_prefix, time, $last_n++);
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;
143 sub get_status_from_callfile {
146 if (not open FH, "<$filename") {
147 syslog(LOG_ERR, "error opening $filename: $!");
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));
160 seek(FH, -64, 2); # go to end of file. back up enough to read short line.
165 if (my $lastline = pop @lines) { # sic, assignment
166 $status = $1 if $lastline =~ /^Status: (\w+)$/;
169 return ($status, @event_ids);
174 my $from = $config{done_path} . '/' . $basename;
175 my $to = $config{ack_path} . '/' . $basename;
177 if (not rename($from, $to)) {
178 syslog LOG_ERR, "ack_callfile() could not move '$from' to '$to'";
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).
189 # The optional argument $with_filenames is for internal use by ack_failures().
192 my ($with_filenames) = @_;
194 if (not opendir DIR, $config{done_path}) {
195 syslog LOG_ERR, "could not opendir $config{done_path}: $!";
199 my @files = grep { /^${universal_prefix}.+\.call$/ } readdir DIR;
204 no warnings 'uninitialized';
206 foreach my $filename (@files) {
207 my ($status, @event_ids) =
208 get_status_from_callfile($config{done_path} . '/' . $filename);
210 if ($status ne 'Completed') {
211 if ($with_filenames) {
212 $result_tree{$filename} = [@event_ids];
214 push @result_set, @event_ids;
219 return ($with_filenames ? \%result_tree : \@result_set);
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.
225 # Returns the number of files archived for informational purposes only.
228 my @event_ids = map(int, (grep defined, @{shift()}));
230 my %lookup = map { $_ => 1 } @event_ids;
232 my $known_failures = get_failures(1); # 1 means "with filenames"
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{$_};
240 $archived += ack_callfile($filename);
249 return -1 unless exists $config{holidays};
250 return -2 unless @$holidays <= $config{holiday_limit};
252 if (-e $config{holidays}) {
253 rename($config{holidays}, $config{holidays} . ".bak") or return -3;
257 open HOLIDAYS, ">$config{holidays}" or return -4;
259 foreach (@$holidays) {
260 next unless @$_ == 2;
262 print HOLIDAYS sprintf("%d,%d\n", @$_);
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?
276 code => 200, # optimism
277 use_allocator => $config{use_allocator},
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
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.
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
304 $data .= sprintf("; %d of %d queued files replaced\n", scalar(@hits) - scalar(@fails), scalar(@hits));
306 $fname = $requested_filename;
308 $fname = auto_filename;
311 $fname = prefixer($fname); # guarantee universal prefix
312 $fname =~ /\.call$/ or $fname .= '.call'; # guarantee .call suffix
314 my $stage_name = $config{staging_path} . "/" . $fname;
315 my $finalized_filename = $config{spool_path} . "/" . $fname;
317 $data .= ";; added by inject() in the mediator\n";
318 $data .= "Set: callfilename=$fname\n";
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: $!");
325 chown($config{owner}, $config{group}, $stage_name) or
327 "error changing $stage_name to $config{owner}:$config{group}: $!"
330 if ($timestamp and $timestamp > 0) {
331 utime $timestamp, $timestamp, $stage_name or
332 return &$failure("error utime'ing $stage_name to $timestamp: $!");
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.
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";
346 syslog LOG_ERR, "rename $stage_name ==> $finalized_filename: $!";
347 return &$failure("rename $stage_name ==> $finalized_filename: $!");
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: $!";
360 # Regarding signatures:
361 # ~ the first datatype is for RETURN value,
362 # ~ any other datatypes are for INCOMING args
366 name => 'inject', code => \&inject, signature => ['struct string', 'struct string string', 'struct string string int']
370 name => 'get_failures',
371 code => \&get_failures,
372 signature => ['array']
376 name => 'ack_failures',
377 code => \&ack_failures,
378 signature => ['int array']
382 name => 'set_holidays',
383 code => \&set_holidays,
384 signature => ['int array']
387 $server->add_default_methods;
388 $server->server_loop;
392 exit main @ARGV; # do it all!