ce1282131be1b0111a2feedb4048c73551a430dd
[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/) {
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!