FS/FS/part_export/sqlradius.pm

   1 package FS::part_export::sqlradius;
   2
   3 use vars qw(@ISA $DEBUG %info %options $notes1 $notes2);
   4 use Tie::IxHash;
   5 use FS::Record qw( dbh qsearch qsearchs );
   6 use FS::part_export;
   7 use FS::svc_acct;
   8 use FS::export_svc;
   9
  10 @ISA = qw(FS::part_export);
  11
  12 $DEBUG = 0;
  13
  14 tie %options, 'Tie::IxHash',
  15   'datasrc'  => { label=>'DBI data source ' },
  16   'username' => { label=>'Database username' },
  17   'password' => { label=>'Database password' },
  18   'ignore_accounting' => {
  19     type  => 'checkbox',
  20     label => 'Ignore accounting records from this database'
  21   },
  22   'hide_ip' => {
  23     type  => 'checkbox',
  24     label => 'Hide IP address information on session reports',
  25   },
  26   'hide_data' => {
  27     type  => 'checkbox',
  28     label => 'Hide download/upload information on session reports',
  29   },
  30   'show_called_station' => {
  31     type  => 'checkbox',
  32     label => 'Show the Called-Station-ID on session reports',
  33   },
  34   'overlimit_groups' => { label => 'Radius groups to assign to svc_acct which has exceeded its bandwidth or time limit', } ,
  35   'groups_susp_reason' => { label =>
  36                              'Radius group mapping to reason (via template user) (svcnum|username|username@domain  reasonnum|reason)',
  37                             type  => 'textarea',
  38                           },
  39
  40 ;
  41
  42 $notes1 = <<'END';
  43 Real-time export of <b>radcheck</b>, <b>radreply</b> and <b>usergroup</b>
  44 tables to any SQL database for
  45 <a href="http://www.freeradius.org/">FreeRADIUS</a>
  46 or <a href="http://radius.innercite.com/">ICRADIUS</a>.
  47 END
  48
  49 $notes2 = <<'END';
  50 An existing RADIUS database will be updated in realtime, but you can use
  51 <a href="../docs/man/bin/freeside-sqlradius-reset">freeside-sqlradius-reset</a>
  52 to delete the entire RADIUS database and repopulate the tables from the
  53 Freeside database.  See the
  54 <a href="http://search.cpan.org/dist/DBI/DBI.pm#connect">DBI documentation</a>
  55 and the
  56 <a href="http://search.cpan.org/search?mode=module&query=DBD%3A%3A">documentation for your DBD</a>
  57 for the exact syntax of a DBI data source.
  58 <ul>
  59   <li>Using FreeRADIUS 0.9.0 with the PostgreSQL backend, the db_postgresql.sql schema and postgresql.conf queries contain incompatible changes.  This is fixed in 0.9.1.  Only new installs with 0.9.0 and PostgreSQL are affected - upgrades and other database backends and versions are unaffected.
  60   <li>Using ICRADIUS, add a dummy "op" column to your database:
  61     <blockquote><code>
  62       ALTER&nbsp;TABLE&nbsp;radcheck&nbsp;ADD&nbsp;COLUMN&nbsp;op&nbsp;VARCHAR(2)&nbsp;NOT&nbsp;NULL&nbsp;DEFAULT&nbsp;'=='<br>
  63       ALTER&nbsp;TABLE&nbsp;radreply&nbsp;ADD&nbsp;COLUMN&nbsp;op&nbsp;VARCHAR(2)&nbsp;NOT&nbsp;NULL&nbsp;DEFAULT&nbsp;'=='<br>
  64       ALTER&nbsp;TABLE&nbsp;radgroupcheck&nbsp;ADD&nbsp;COLUMN&nbsp;op&nbsp;VARCHAR(2)&nbsp;NOT&nbsp;NULL&nbsp;DEFAULT&nbsp;'=='<br>
  65       ALTER&nbsp;TABLE&nbsp;radgroupreply&nbsp;ADD&nbsp;COLUMN&nbsp;op&nbsp;VARCHAR(2)&nbsp;NOT&nbsp;NULL&nbsp;DEFAULT&nbsp;'=='
  66     </code></blockquote>
  67   <li>Using Radiator, see the
  68     <a href="http://www.open.com.au/radiator/faq.html#38">Radiator FAQ</a>
  69     for configuration information.
  70 </ul>
  71 END
  72
  73 %info = (
  74   'svc'      => 'svc_acct',
  75   'desc'     => 'Real-time export to SQL-backed RADIUS (FreeRADIUS, ICRADIUS)',
  76   'options'  => \%options,
  77   'nodomain' => 'Y',
  78   'notes'    => $notes1.
  79                 'This export does not export RADIUS realms (see also '.
  80                 'sqlradius_withdomain).  '.
  81                 $notes2
  82 );
  83
  84 sub _groups_susp_reason_map { map { reverse( /^\s*(\S+)\s*(.*)$/ ) }
  85                               split( "\n", shift->option('groups_susp_reason'));
  86 }
  87
  88 sub rebless { shift; }
  89
  90 sub export_username {
  91   my($self, $svc_acct) = (shift, shift);
  92   warn "export_username called on $self with arg $svc_acct" if $DEBUG;
  93   $svc_acct->username;
  94 }
  95
  96 sub _export_insert {
  97   my($self, $svc_acct) = (shift, shift);
  98
  99   foreach my $table (qw(reply check)) {
 100     my $method = "radius_$table";
 101     my %attrib = $svc_acct->$method();
 102     next unless keys %attrib;
 103     my $err_or_queue = $self->sqlradius_queue( $svc_acct->svcnum, 'insert',
 104       $table, $self->export_username($svc_acct), %attrib );
 105     return $err_or_queue unless ref($err_or_queue);
 106   }
 107   my @groups = $svc_acct->radius_groups;
 108   if ( @groups ) {
 109     my $err_or_queue = $self->sqlradius_queue(
 110       $svc_acct->svcnum, 'usergroup_insert',
 111       $self->export_username($svc_acct), @groups );
 112     return $err_or_queue unless ref($err_or_queue);
 113   }
 114   '';
 115 }
 116
 117 sub _export_replace {
 118   my( $self, $new, $old ) = (shift, shift, shift);
 119
 120   local $SIG{HUP} = 'IGNORE';
 121   local $SIG{INT} = 'IGNORE';
 122   local $SIG{QUIT} = 'IGNORE';
 123   local $SIG{TERM} = 'IGNORE';
 124   local $SIG{TSTP} = 'IGNORE';
 125   local $SIG{PIPE} = 'IGNORE';
 126
 127   my $oldAutoCommit = $FS::UID::AutoCommit;
 128   local $FS::UID::AutoCommit = 0;
 129   my $dbh = dbh;
 130
 131   my $jobnum = '';
 132   if ( $self->export_username($old) ne $self->export_username($new) ) {
 133     my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'rename',
 134       $self->export_username($new), $self->export_username($old) );
 135     unless ( ref($err_or_queue) ) {
 136       $dbh->rollback if $oldAutoCommit;
 137       return $err_or_queue;
 138     }
 139     $jobnum = $err_or_queue->jobnum;
 140   }
 141
 142   foreach my $table (qw(reply check)) {
 143     my $method = "radius_$table";
 144     my %new = $new->$method();
 145     my %old = $old->$method();
 146     if ( grep { !exists $old{$_} #new attributes
 147                 || $new{$_} ne $old{$_} #changed
 148               } keys %new
 149     ) {
 150       my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
 151         $table, $self->export_username($new), %new );
 152       unless ( ref($err_or_queue) ) {
 153         $dbh->rollback if $oldAutoCommit;
 154         return $err_or_queue;
 155       }
 156       if ( $jobnum ) {
 157         my $error = $err_or_queue->depend_insert( $jobnum );
 158         if ( $error ) {
 159           $dbh->rollback if $oldAutoCommit;
 160           return $error;
 161         }
 162       }
 163     }
 164
 165     my @del = grep { !exists $new{$_} } keys %old;
 166     if ( @del ) {
 167       my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'attrib_delete',
 168         $table, $self->export_username($new), @del );
 169       unless ( ref($err_or_queue) ) {
 170         $dbh->rollback if $oldAutoCommit;
 171         return $err_or_queue;
 172       }
 173       if ( $jobnum ) {
 174         my $error = $err_or_queue->depend_insert( $jobnum );
 175         if ( $error ) {
 176           $dbh->rollback if $oldAutoCommit;
 177           return $error;
 178         }
 179       }
 180     }
 181   }
 182
 183   my $error;
 184   my (@oldgroups) = $old->radius_groups;
 185   my (@newgroups) = $new->radius_groups;
 186   $error = $self->sqlreplace_usergroups( $new->svcnum,
 187                                          $self->export_username($new),
 188                                          $jobnum ? $jobnum : '',
 189                                          \@oldgroups,
 190                                          \@newgroups,
 191                                        );
 192   if ( $error ) {
 193     $dbh->rollback if $oldAutoCommit;
 194     return $error;
 195   }
 196
 197   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 198
 199   '';
 200 }
 201
 202 sub _export_suspend {
 203   my( $self, $svc_acct ) = (shift, shift);
 204
 205   my $new = $svc_acct->clone_suspended;
 206
 207   local $SIG{HUP} = 'IGNORE';
 208   local $SIG{INT} = 'IGNORE';
 209   local $SIG{QUIT} = 'IGNORE';
 210   local $SIG{TERM} = 'IGNORE';
 211   local $SIG{TSTP} = 'IGNORE';
 212   local $SIG{PIPE} = 'IGNORE';
 213
 214   my $oldAutoCommit = $FS::UID::AutoCommit;
 215   local $FS::UID::AutoCommit = 0;
 216   my $dbh = dbh;
 217
 218   my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert',
 219     'check', $self->export_username($new), $new->radius_check );
 220   unless ( ref($err_or_queue) ) {
 221     $dbh->rollback if $oldAutoCommit;
 222     return $err_or_queue;
 223   }
 224
 225   my $error;
 226   my (@newgroups) = $self->suspended_usergroups($svc_acct);
 227   $error =
 228     $self->sqlreplace_usergroups( $new->svcnum,
 229                                   $self->export_username($new),
 230                                   '',
 231                                   $svc_acct->usergroup,
 232                                   \@newgroups,
 233                                 );
 234   if ( $error ) {
 235     $dbh->rollback if $oldAutoCommit;
 236     return $error;
 237   }
 238   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 239
 240   '';
 241 }
 242
 243 sub _export_unsuspend {
 244   my( $self, $svc_acct ) = (shift, shift);
 245
 246   local $SIG{HUP} = 'IGNORE';
 247   local $SIG{INT} = 'IGNORE';
 248   local $SIG{QUIT} = 'IGNORE';
 249   local $SIG{TERM} = 'IGNORE';
 250   local $SIG{TSTP} = 'IGNORE';
 251   local $SIG{PIPE} = 'IGNORE';
 252
 253   my $oldAutoCommit = $FS::UID::AutoCommit;
 254   local $FS::UID::AutoCommit = 0;
 255   my $dbh = dbh;
 256
 257   my $err_or_queue = $self->sqlradius_queue( $svc_acct->svcnum, 'insert',
 258     'check', $self->export_username($svc_acct), $svc_acct->radius_check );
 259   unless ( ref($err_or_queue) ) {
 260     $dbh->rollback if $oldAutoCommit;
 261     return $err_or_queue;
 262   }
 263
 264   my $error;
 265   my (@oldgroups) = $self->suspended_usergroups($svc_acct);
 266   $error = $self->sqlreplace_usergroups( $svc_acct->svcnum,
 267                                          $self->export_username($svc_acct),
 268                                          '',
 269                                          \@oldgroups,
 270                                          $svc_acct->usergroup,
 271                                        );
 272   if ( $error ) {
 273     $dbh->rollback if $oldAutoCommit;
 274     return $error;
 275   }
 276   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 277
 278   '';
 279 }
 280
 281 sub _export_delete {
 282   my( $self, $svc_acct ) = (shift, shift);
 283   my $err_or_queue = $self->sqlradius_queue( $svc_acct->svcnum, 'delete',
 284     $self->export_username($svc_acct) );
 285   ref($err_or_queue) ? '' : $err_or_queue;
 286 }
 287
 288 sub sqlradius_queue {
 289   my( $self, $svcnum, $method ) = (shift, shift, shift);
 290   my $queue = new FS::queue {
 291     'svcnum' => $svcnum,
 292     'job'    => "FS::part_export::sqlradius::sqlradius_$method",
 293   };
 294   $queue->insert(
 295     $self->option('datasrc'),
 296     $self->option('username'),
 297     $self->option('password'),
 298     @_,
 299   ) or $queue;
 300 }
 301
 302 sub suspended_usergroups {
 303   my ($self, $svc_acct) = (shift, shift);
 304
 305   return () unless $svc_acct;
 306
 307   #false laziness with FS::part_export::shellcommands
 308   #subclass part_export?
 309
 310   my $r = $svc_acct->cust_svc->cust_pkg->last_reason;
 311   my %reasonmap = $self->_groups_susp_reason_map;
 312   my $userspec = '';
 313   if ($r) {
 314     $userspec = $reasonmap{$r->reasonnum}
 315       if exists($reasonmap{$r->reasonnum});
 316     $userspec = $reasonmap{$r->reason}
 317       if (!$userspec && exists($reasonmap{$r->reason}));
 318   }
 319   my $suspend_user;
 320   if ($userspec =~ /^d+$/ ){
 321     $suspend_user = qsearchs( 'svc_acct', { 'svcnum' => $userspec } );
 322   }elsif ($userspec =~ /^\S+\@\S+$/){
 323     my ($username,$domain) = split(/\@/, $userspec);
 324     for my $user (qsearch( 'svc_acct', { 'username' => $username } )){
 325       $suspend_user = $user if $userspec eq $user->email;
 326     }
 327   }elsif ($userspec){
 328     $suspend_user = qsearchs( 'svc_acct', { 'username' => $userspec } );
 329   }
 330   #esalf
 331   return $suspend_user->radius_groups if $suspend_user;
 332   ();
 333 }
 334
 335 sub sqlradius_insert { #subroutine, not method
 336   my $dbh = sqlradius_connect(shift, shift, shift);
 337   my( $table, $username, %attributes ) = @_;
 338
 339   foreach my $attribute ( keys %attributes ) {
 340
 341     my $s_sth = $dbh->prepare(
 342       "SELECT COUNT(*) FROM rad$table WHERE UserName = ? AND Attribute = ?"
 343     ) or die $dbh->errstr;
 344     $s_sth->execute( $username, $attribute ) or die $s_sth->errstr;
 345
 346     if ( $s_sth->fetchrow_arrayref->[0] ) {
 347
 348       my $u_sth = $dbh->prepare(
 349         "UPDATE rad$table SET Value = ? WHERE UserName = ? AND Attribute = ?"
 350       ) or die $dbh->errstr;
 351       $u_sth->execute($attributes{$attribute}, $username, $attribute)
 352         or die $u_sth->errstr;
 353
 354     } else {
 355
 356       my $i_sth = $dbh->prepare(
 357         "INSERT INTO rad$table ( UserName, Attribute, op, Value ) ".
 358           "VALUES ( ?, ?, ?, ? )"
 359       ) or die $dbh->errstr;
 360       $i_sth->execute(
 361         $username,
 362         $attribute,
 363         ( $attribute =~ /Password/i ? '==' : ':=' ),
 364         $attributes{$attribute},
 365       ) or die $i_sth->errstr;
 366
 367     }
 368
 369   }
 370   $dbh->disconnect;
 371 }
 372
 373 sub sqlradius_usergroup_insert { #subroutine, not method
 374   my $dbh = sqlradius_connect(shift, shift, shift);
 375   my( $username, @groups ) = @_;
 376
 377   my $s_sth = $dbh->prepare(
 378     "SELECT COUNT(*) FROM usergroup WHERE UserName = ? AND GroupName = ?"
 379   ) or die $dbh->errstr;
 380
 381   my $sth = $dbh->prepare(
 382     "INSERT INTO usergroup ( UserName, GroupName ) VALUES ( ?, ? )"
 383   ) or die $dbh->errstr;
 384
 385   foreach my $group ( @groups ) {
 386     $s_sth->execute( $username, $group ) or die $s_sth->errstr;
 387     next if $s_sth->fetchrow_arrayref->[0];
 388     $sth->execute( $username, $group )
 389       or die "can't insert into groupname table: ". $sth->errstr;
 390   }
 391   $dbh->disconnect;
 392 }
 393
 394 sub sqlradius_usergroup_delete { #subroutine, not method
 395   my $dbh = sqlradius_connect(shift, shift, shift);
 396   my( $username, @groups ) = @_;
 397
 398   my $sth = $dbh->prepare(
 399     "DELETE FROM usergroup WHERE UserName = ? AND GroupName = ?"
 400   ) or die $dbh->errstr;
 401   foreach my $group ( @groups ) {
 402     $sth->execute( $username, $group )
 403       or die "can't delete from groupname table: ". $sth->errstr;
 404   }
 405   $dbh->disconnect;
 406 }
 407
 408 sub sqlradius_rename { #subroutine, not method
 409   my $dbh = sqlradius_connect(shift, shift, shift);
 410   my($new_username, $old_username) = @_;
 411   foreach my $table (qw(radreply radcheck usergroup )) {
 412     my $sth = $dbh->prepare("UPDATE $table SET Username = ? WHERE UserName = ?")
 413       or die $dbh->errstr;
 414     $sth->execute($new_username, $old_username)
 415       or die "can't update $table: ". $sth->errstr;
 416   }
 417   $dbh->disconnect;
 418 }
 419
 420 sub sqlradius_attrib_delete { #subroutine, not method
 421   my $dbh = sqlradius_connect(shift, shift, shift);
 422   my( $table, $username, @attrib ) = @_;
 423
 424   foreach my $attribute ( @attrib ) {
 425     my $sth = $dbh->prepare(
 426         "DELETE FROM rad$table WHERE UserName = ? AND Attribute = ?" )
 427       or die $dbh->errstr;
 428     $sth->execute($username,$attribute)
 429       or die "can't delete from rad$table table: ". $sth->errstr;
 430   }
 431   $dbh->disconnect;
 432 }
 433
 434 sub sqlradius_delete { #subroutine, not method
 435   my $dbh = sqlradius_connect(shift, shift, shift);
 436   my $username = shift;
 437
 438   foreach my $table (qw( radcheck radreply usergroup )) {
 439     my $sth = $dbh->prepare( "DELETE FROM $table WHERE UserName = ?" );
 440     $sth->execute($username)
 441       or die "can't delete from $table table: ". $sth->errstr;
 442   }
 443   $dbh->disconnect;
 444 }
 445
 446 sub sqlradius_connect {
 447   #my($datasrc, $username, $password) = @_;
 448   #DBI->connect($datasrc, $username, $password) or die $DBI::errstr;
 449   DBI->connect(@_) or die $DBI::errstr;
 450 }
 451
 452 sub sqlreplace_usergroups {
 453   my ($self, $svcnum, $username, $jobnum, $old, $new) = @_;
 454
 455   # (sorta) false laziness with FS::svc_acct::replace
 456   my @oldgroups = @$old;
 457   my @newgroups = @$new;
 458   my @delgroups = ();
 459   foreach my $oldgroup ( @oldgroups ) {
 460     if ( grep { $oldgroup eq $_ } @newgroups ) {
 461       @newgroups = grep { $oldgroup ne $_ } @newgroups;
 462       next;
 463     }
 464     push @delgroups, $oldgroup;
 465   }
 466
 467   if ( @delgroups ) {
 468     my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_delete',
 469       $username, @delgroups );
 470     return $err_or_queue
 471       unless ref($err_or_queue);
 472     if ( $jobnum ) {
 473       my $error = $err_or_queue->depend_insert( $jobnum );
 474       return $error if $error;
 475     }
 476   }
 477
 478   if ( @newgroups ) {
 479     my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_insert',
 480       $username, @newgroups );
 481     return $err_or_queue
 482       unless ref($err_or_queue);
 483     if ( $jobnum ) {
 484       my $error = $err_or_queue->depend_insert( $jobnum );
 485       return $error if $error;
 486     }
 487   }
 488   '';
 489 }
 490
 491
 492 #--
 493
 494 =item usage_sessions TIMESTAMP_START TIMESTAMP_END [ SVC_ACCT [ IP [ PREFIX [ SQL_SELECT ] ] ] ]
 495
 496 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 497 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 498 functions.
 499
 500 SVC_ACCT, if specified, limits the results to the specified account.
 501
 502 IP, if specified, limits the results to the specified IP address.
 503
 504 PREFIX, if specified, limits the results to records with a matching
 505 Called-Station-ID.
 506
 507 #SQL_SELECT defaults to * if unspecified.  It can be useful to set it to
 508 #SUM(acctsessiontime) or SUM(AcctInputOctets), etc.
 509
 510 Returns an arrayref of hashrefs with the following fields:
 511
 512 =over 4
 513
 514 =item username
 515
 516 =item framedipaddress
 517
 518 =item acctstarttime
 519
 520 =item acctstoptime
 521
 522 =item acctsessiontime
 523
 524 =item acctinputoctets
 525
 526 =item acctoutputoctets
 527
 528 =item calledstationid
 529
 530 =back
 531
 532 =cut
 533
 534 #some false laziness w/cust_svc::seconds_since_sqlradacct
 535
 536 sub usage_sessions {
 537   my( $self, $start, $end ) = splice(@_, 0, 3);
 538   my $svc_acct = @_ ? shift : '';
 539   my $ip = @_ ? shift : '';
 540   my $prefix = @_ ? shift : '';
 541   #my $select = @_ ? shift : '*';
 542
 543   $end ||= 2147483647;
 544
 545   return [] if $self->option('ignore_accounting');
 546
 547   my $dbh = sqlradius_connect( map $self->option($_),
 548                                    qw( datasrc username password ) );
 549
 550   #select a unix time conversion function based on database type
 551   my $str2time;
 552   if ( $dbh->{Driver}->{Name} =~ /^mysql(PP)?$/ ) {
 553     $str2time = 'UNIX_TIMESTAMP(';
 554   } elsif ( $dbh->{Driver}->{Name} eq 'Pg' ) {
 555     $str2time = 'EXTRACT( EPOCH FROM ';
 556   } else {
 557     warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
 558          "; guessing how to convert to UNIX timestamps";
 559     $str2time = 'extract(epoch from ';
 560   }
 561
 562   my @fields = (
 563                  qw( username realm framedipaddress
 564                      acctsessiontime acctinputoctets acctoutputoctets
 565                      calledstationid
 566                    ),
 567                  "$str2time acctstarttime ) as acctstarttime",
 568                  "$str2time acctstoptime ) as acctstoptime",
 569                );
 570
 571   my @param = ();
 572   my $where = '';
 573
 574   if ( $svc_acct ) {
 575     my $username = $self->export_username($svc_acct);
 576     if ( $svc_acct =~ /^([^@]+)\@([^@]+)$/ ) {
 577       $where = '( UserName = ? OR ( UserName = ? AND Realm = ? ) ) AND';
 578       push @param, $username, $1, $2;
 579     } else {
 580       $where = 'UserName = ? AND';
 581       push @param, $username;
 582     }
 583   }
 584
 585   if ( length($ip) ) {
 586     $where .= ' FramedIPAddress = ? AND';
 587     push @param, $ip;
 588   }
 589
 590   if ( length($prefix) ) {
 591     #assume sip: for now, else things get ugly trying to match /^\w+:$prefix/
 592     $where .= " CalledStationID LIKE 'sip:$prefix\%' AND";
 593   }
 594
 595   push @param, $start, $end;
 596
 597   my $sth = $dbh->prepare('SELECT '. join(', ', @fields).
 598                           "  FROM radacct
 599                              WHERE $where
 600                                    $str2time AcctStopTime ) >= ?
 601                                AND $str2time AcctStopTime ) <=  ?
 602                                ORDER BY AcctStartTime DESC
 603   ") or die $dbh->errstr;
 604   $sth->execute(@param) or die $sth->errstr;
 605
 606   [ map { { %$_ } } @{ $sth->fetchall_arrayref({}) } ];
 607
 608 }
 609
 610 =item update_svc_acct
 611
 612 =cut
 613
 614 sub update_svc_acct {
 615   my $self = shift;
 616
 617   my $dbh = sqlradius_connect( map $self->option($_),
 618                                    qw( datasrc username password ) );
 619
 620   my @fields = qw( radacctid username realm acctsessiontime );
 621
 622   my @param = ();
 623   my $where = '';
 624
 625   my $sth = $dbh->prepare("
 626     SELECT RadAcctId, UserName, Realm, AcctSessionTime,
 627            AcctInputOctets, AcctOutputOctets
 628       FROM radacct
 629       WHERE FreesideStatus IS NULL
 630         AND AcctStopTime != 0
 631   ") or die $dbh->errstr;
 632   $sth->execute() or die $sth->errstr;
 633
 634   while ( my $row = $sth->fetchrow_arrayref ) {
 635     my($RadAcctId, $UserName, $Realm, $AcctSessionTime,
 636        $AcctInputOctets, $AcctOutputOctets) = @$row;
 637     warn "processing record: ".
 638          "$RadAcctId ($UserName\@$Realm for ${AcctSessionTime}s"
 639       if $DEBUG;
 640
 641     my %search = ( 'username' => $UserName );
 642     my $extra_sql = '';
 643     if ( ref($self) =~ /withdomain/ ) { #well...
 644       $extra_sql = " AND '$Realm' = ( SELECT domain FROM svc_domain
 645                           WHERE svc_domain.svcnum = svc_acct.domsvc ) ";
 646     }
 647
 648     my @svc_acct =
 649       grep { qsearch( 'export_svc', { 'exportnum' => $self->exportnum,
 650                                       'svcpart'   => $_->cust_svc->svcpart, } )
 651            }
 652       qsearch( 'svc_acct',
 653                  { 'username' => $UserName },
 654                  '',
 655                  $extra_sql
 656                );
 657
 658     my $errinfo = "for RADIUS detail RadAcctID $RadAcctId ".
 659                   "(UserName $UserName, Realm $Realm)";
 660     my $status = 'skipped';
 661     if ( !@svc_acct ) {
 662       warn "WARNING: no svc_acct record found $errinfo - skipping\n";
 663     } elsif ( scalar(@svc_acct) > 1 ) {
 664       warn "WARNING: multiple svc_acct records found $errinfo - skipping\n";
 665     } else {
 666       warn "found svc_acct ". $svc_acct[0]->svcnum. " $errinfo\n" if $DEBUG;
 667       _try_decrement($svc_acct[0], 'seconds', $AcctSessionTime)
 668         and $status='done';
 669       _try_decrement($svc_acct[0], 'upbytes', $AcctInputOctets)
 670         and $status='done';
 671       _try_decrement($svc_acct[0], 'downbytes', $AcctOutputOctets)
 672         and $status='done';
 673       _try_decrement($svc_acct[0], 'totalbytes', $AcctInputOctets +
 674                      $AcctOutputOctets)
 675         and $status='done';
 676     }
 677
 678     warn "setting FreesideStatus to $status $errinfo\n" if $DEBUG;
 679     my $psth = $dbh->prepare("UPDATE radacct
 680                                 SET FreesideStatus = ?
 681                                 WHERE RadAcctId = ?"
 682     ) or die $dbh->errstr;
 683     $psth->execute($status, $RadAcctId) or die $psth->errstr;
 684
 685   }
 686
 687 }
 688
 689 sub _try_decrement {
 690   my ($svc_acct, $column, $amount) = @_;
 691   if ( $svc_acct->$column !~ /^$/ ) {
 692     warn "  svc_acct.$column found (". $svc_acct->$column.
 693          ") - decrementing\n"
 694       if $DEBUG;
 695     my $method = 'decrement_' . $column;
 696     my $error = $svc_acct->$method($amount);
 697     die $error if $error;
 698     return 'done';
 699   } else {
 700     warn "  no existing $column value for svc_acct - skipping\n" if $DEBUG;
 701   }
 702   return '';
 703 }
 704
 705 1;
 706