better diagnostics for un-pre-rate-able CDRs
[freeside.git] / FS / bin / freeside-torrus-srvderive
1 #!/usr/bin/perl -w
2
3 use strict;
4 use POSIX qw( :sys_wait_h );
5 use Sys::SigAction qw( set_sig_handler );
6 use Date::Parse;
7 use Date::Format;
8 use IPC::Run qw( run ); #timeout );
9 use FS::Daemon ':all'; #daemonize1 drop_root daemonize2 myexit logfile sig*
10 use FS::UID qw( adminsuidsetup forksuidsetup dbh driver_name );
11 use FS::Record qw( qsearch );
12 use FS::torrus_srvderive;
13
14 our $DEBUG = 2;
15 our $max_kids = 4;
16 our %kids;
17
18 my $user = shift or die &usage;
19 $FS::Daemon::PID_NEWSTYLE = 1;
20 daemonize1('torrus-srvderive');
21
22 drop_root();
23
24 adminsuidsetup($user);
25
26 logfile( "%%%FREESIDE_LOG%%%/torrus-srvderive-log.". $FS::UID::datasrc );
27
28 daemonize2();
29
30 our $conf = new FS::Conf;
31
32 die "not running: network_monitoring_system not Torrus_Internal\n"
33   unless _shouldrun();
34
35 #--
36
37 our $kids = 0;
38
39 #MAIN: while (1) {
40 while (1) {
41
42   #SERVICEID: foreach my $torrus_srvderive ( qsearch('torrus_srvderive', {}) ) {
43   foreach my $torrus_srvderive ( qsearch('torrus_srvderive', {}) ) {
44
45     &reap_kids;
46     if ( $kids >= $max_kids ) {
47       sleep 5;
48       myexit() if sigterm() || sigint();
49       redo;
50     }
51
52     defined( my $pid = fork ) or do {
53       #warn "WARNING: can't fork: $!\n";
54       #next; #don't increment the kid counter
55       die "can't fork: $!\n";
56     };
57
58     if ( $pid ) {
59       $kids++;
60       $kids{$pid} = 1;
61     } else { #kid time
62
63       #get new db handle
64       $FS::UID::dbh->{InactiveDestroy} = 1;
65
66       forksuidsetup($user);
67
68       my $serviceid = $torrus_srvderive->serviceid;
69
70       my @serviceids = $torrus_srvderive->component_serviceids;
71       exit unless @serviceids; #don't try to search for empty virtual ports
72
73       my @in = ();
74       for my $dir ('_IN', '_OUT') {
75         push @in, map dbh->quote("$_$dir"), @serviceids;
76       }
77       my $in = join(',', @in);
78
79       if ( ! $torrus_srvderive->last_srv_date ) {
80         warn "finding initial last_srv_date for $serviceid\n" if $DEBUG;
81         my $dsql = "SELECT srv_date FROM srvexport WHERE serviceid IN ($in)
82                     ORDER BY srv_date LIMIT 1";
83         my $dsth = dbh->prepare($dsql) or die $DBI::errstr;
84         $dsth->execute or die $dsth->errstr;
85         my $row = $dsth->fetchrow_arrayref;
86         my $date = (defined($row) && ref($row)) ? $row->[0] : '';
87         if ( $date ) {
88           warn "found initial last_srv_date of $date; updating $serviceid\n"
89             if $DEBUG;
90           $torrus_srvderive->last_srv_date($date);
91           my $error = $torrus_srvderive->replace;
92           die $error if $error;
93         } else {
94           warn "no initial last_srv_date for $serviceid; skipping\n" if $DEBUG;
95           exit;
96         }
97       }
98
99       #if we're more than a day behind, call native torrus srvderive
100       my $last_srv_date = $torrus_srvderive->last_srv_date;
101       my $currdate = time2str('%Y-%m-%d', time);
102       if ( $last_srv_date ne $currdate
103            && time - str2time($last_srv_date) > (24)*60*60
104          ) {
105         warn "serviceid $serviceid last_srv_date != $currdate\n" if $DEBUG;
106
107         #delete records from last_srv_date
108         my $dsql =
109           'DELETE FROM srvexport WHERE srv_date = ? AND serviceid IN(?,?)';
110         my $dsth = dbh->prepare($dsql) or die $DBI::errstr;
111         warn "$dsql $last_srv_date ${serviceid}_IN ${serviceid}_OUT\n"
112           if $DEBUG;
113         $dsth->execute($last_srv_date, $serviceid.'_IN', $serviceid.'_OUT')
114           or die $dsth->errstr;
115         dbh->commit or die dbh->errstr;
116
117         foreach my $dir ('_IN','_OUT') {
118
119           #XX TORRUS_PATH
120           my @cmd = ( '/usr/local/bin/torrus', 'srvderive',
121                         "--start=$last_srv_date", "--end=$currdate",
122                         "--out=$serviceid$dir", "--func=SUM",
123                         map "$_$dir", @serviceids
124                     );
125
126           warn "calling native srvderive: ". join(' ', @cmd). "\n" if $DEBUG;
127           my $out_and_err = '';
128           run( \@cmd, '>&', \$out_and_err ) #verbose?  timeout?
129             or die "error calling native srvderive: $out_and_err\n";
130
131         }
132         warn "native srvderive done" if $DEBUG;
133
134         $torrus_srvderive->last_srv_date($currdate);
135         my $error = $torrus_srvderive->replace;
136         die $error if $error;
137
138         #don't bother trying today's immediately
139         warn "done with $serviceid for now\n" if $DEBUG;
140
141       } else {
142
143         warn "serviceid $serviceid last_srv_date == $currdate; skipping\n"
144           if $DEBUG;
145
146       }
147
148       exit; #end-of-kid
149
150     }
151
152   } #foreach my $torrus_srvderive
153   dbh->commit or die dbh->errstr;
154
155   myexit() if sigterm() || sigint();
156   warn "sleeping an hour\n" if $DEBUG > 1;
157   sleep 60*60;
158   warn "restarting main loop\n" if $DEBUG > 1;
159 }
160
161 sub _shouldrun {
162      $conf->exists('network_monitoring_system')
163   && $conf->config('network_monitoring_system') eq 'Torrus_Internal';
164 }
165
166 sub usage { 
167   die "Usage:\n\n  freeside-cdrrewrited user\n";
168 }
169
170 sub reap_kids {
171   foreach my $pid ( keys %kids ) {
172     my $kid = waitpid($pid, WNOHANG);
173     if ( $kid > 0 ) {
174       $kids--;
175       delete $kids{$kid};
176     }
177   }
178 }
179
180 =head1 NAME
181
182 freeside-torrus-srvderive - Freeside's Torrus virtual port daemon.
183
184 =head1 SYNOPSIS
185
186   freeside-torrus-srvderive
187
188 =head1 DESCRIPTION
189
190 Runs continuously, searches for samples in the srvexport table which do not
191 have an entry for combined virtual ports, and adds them.
192
193 =head1 SEE ALSO
194
195 =cut
196
197 1;
198