New features for telephony currently in use at KCLS
[Evergreen.git] / 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!