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/) {
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;
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?
149 code => 200, # optimism
150 use_allocator => $config{use_allocator},
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
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.
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
177 $data .= sprintf("; %d of %d queued files replaced\n", scalar(@hits) - scalar(@fails), scalar(@hits));
179 $fname = $requested_filename;
181 $fname = auto_filename;
184 $fname = prefixer($fname); # guarantee universal prefix
185 $fname =~ /\.call$/ or $fname .= '.call'; # guarantee .call suffix
187 my $stage_name = $config{staging_path} . "/" . $fname;
188 my $finalized_filename = $config{spool_path} . "/" . $fname;
190 $data .= ";; added by inject() in the mediator\n";
191 $data .= "Set: callfilename=$fname\n";
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: $!");
198 chown($config{owner}, $config{group}, $stage_name) or
200 "error changing $stage_name to $config{owner}:$config{group}: $!"
203 if ($timestamp and $timestamp > 0) {
204 utime $timestamp, $timestamp, $stage_name or
205 return &$failure("error utime'ing $stage_name to $timestamp: $!");
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.
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";
219 syslog LOG_ERR, "rename $stage_name ==> $finalized_filename: $!";
220 return &$failure("rename $stage_name ==> $finalized_filename: $!");
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..
232 my @matches = grep {-f $_ } <'./' . ${globstring}>; # don't use <$pathglob>, that looks like ref to HANDLE
236 glob_used => $globstring,
237 match_count => scalar(@matches),
240 foreach my $match (@matches) {
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}++;
248 my @content = <FILE>; #slurpy
251 $ret->{'file_' . sprintf("%06d",$i++)} = {
252 filename => fileparse($match),
253 content => join('', @content),
260 # cleanup: deletes files
261 # arguments: string (comma separated filenames), optional int flag
262 # returns: struct reporting success/failure
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.
271 my $targetstring = shift or return &$bad_request(
272 "Must supply at least one filename to cleanup()" # not empty string!
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': $!");
280 code => 200, # optimism
281 request_count => scalar(@targets),
282 from_queue => $dequeue,
289 foreach my $target (@targets) {
291 $target = fileparse($target); # no fair trying to get us to delete in other directories!
292 my $file = $path . '/' . prefixer($target);
294 $problems{$target} = {
295 code => 404, # NOT FOUND: may or may not be a true error, since our purpose was to delete it anyway.
298 syslog LOG_NOTICE, "Delete request $i of " . $ret->{request_count} . " for file '$file': File not found";
302 $ret->{match_count}++;
304 $ret->{delete_count}++;
305 syslog LOG_NOTICE, "Delete request $i of " . $ret->{request_count} . " for file '$file' successful";
307 syslog LOG_ERR, "Delete request $i of " . $ret->{request_count} . " for file '$file' FAILED: $!";
308 $problems{$target} = {
309 code => 403, # FORBIDDEN: permissions problem
316 my $prob_count = scalar keys %problems;
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
324 $ret->{code} = 207; # otherwise, MULTI-STATUS
325 $ret->{multistatus} = \%problems;
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: $!";
338 # Regarding signatures:
339 # ~ the first datatype is for RETURN value,
340 # ~ any other datatypes are for INCOMING args
342 # Everything here returns a struct.
345 name => 'inject', code => \&inject, signature => ['struct string', 'struct string string', 'struct string string int']
348 name => 'retrieve', code => \&retrieve, signature => ['struct string', 'struct']
351 name => 'cleanup', code => \&cleanup, signature => ['struct string', 'struct string int']
354 $server->add_default_methods;
355 $server->server_loop;
359 exit main @ARGV; # do it all!